├── .github └── workflows │ └── run-tests.yml ├── .gitignore ├── B2T2 ├── B2T2.idr ├── B2T2 │ ├── Errors │ │ ├── MalformedTables │ │ │ ├── MissingCell.idr │ │ │ ├── MissingRow.idr │ │ │ ├── MissingSchema.idr │ │ │ ├── SchemaTooLong.idr │ │ │ ├── SchemaTooShort.idr │ │ │ └── SwappedColumns.idr │ │ └── UsingTables │ │ │ ├── BlackAndWhite.idr │ │ │ ├── BrownGetAcne.idr │ │ │ ├── BrownJellyBeans.idr │ │ │ ├── EmployeeToDepartment.idr │ │ │ ├── FavoriteColor.idr │ │ │ ├── GetOnlyRow.idr │ │ │ ├── MidFinal.idr │ │ │ └── PieCount.idr │ ├── ExamplePrograms.idr │ ├── ExamplePrograms │ │ ├── DotProduct.idr │ │ ├── GroupBy.idr │ │ ├── PHacking.idr │ │ ├── PHacking │ │ │ └── FisherTest.idr │ │ ├── QuizScoreFilter.idr │ │ ├── QuizScoreSelect.idr │ │ ├── SampleRows.idr │ │ └── SampleRows │ │ │ └── Probability.idr │ └── ExampleTables.idr ├── Datasheet.md ├── Makefile └── b2t2.ipkg ├── Data ├── Table.idr └── Table │ ├── Column.idr │ ├── Column │ └── Homogeneous.idr │ ├── Data.idr │ ├── Record.idr │ ├── Row.idr │ ├── Row │ ├── Aggregate.idr │ ├── Constructor.idr │ ├── Frame.idr │ ├── HasRows.idr │ ├── Interface.idr │ └── Quantifiers.idr │ ├── Schema.idr │ ├── Schema │ ├── Data.idr │ ├── Index.idr │ ├── Quantifiers.idr │ └── Subschema.idr │ └── Show.idr ├── LICENSE ├── Makefile ├── README.md ├── table.ipkg └── tests ├── B2T2 ├── DotProduct │ ├── expected │ └── run ├── Errors │ ├── expected │ └── run ├── GroupBy │ ├── expected │ └── run ├── PHacking │ ├── expected │ └── run ├── QuizScoreFilter │ ├── expected │ └── run ├── QuizScoreSelect │ ├── expected │ └── run └── SampleRows │ ├── Samples.idr │ ├── expected │ └── run ├── Column ├── ExampleTable.idr ├── expected └── run ├── Frame ├── ExampleTables.idr ├── expected └── run ├── Makefile ├── Record ├── ExampleRecord.idr ├── expected └── run ├── Row ├── ExampleTables.idr ├── expected └── run ├── Schema ├── ExampleSchema.idr ├── expected └── run ├── Show ├── ExampleTables.idr ├── expected └── run ├── Table ├── ExampleTable.idr ├── expected └── run ├── TableTests.idr ├── table-tests.ipkg └── testutils.sh /.github/workflows/run-tests.yml: -------------------------------------------------------------------------------- 1 | name: Run Tests 2 | on: 3 | push: 4 | branches: 5 | - main 6 | pull_request: 7 | branches: 8 | - main 9 | jobs: 10 | run_tests: 11 | name: Run Tests 12 | runs-on: ubuntu-latest 13 | container: snazzybucket/idris2 14 | steps: 15 | - name: Check out Idris2-Table 16 | uses: actions/checkout@v2 17 | - name: Build Idris2-Table 18 | run: make table 19 | - name: Build B2T2 20 | run: make b2t2 21 | - name: Run Tests 22 | run: make test 23 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /build 2 | /B2T2/depends 3 | /B2T2/build 4 | 5 | /tests/build 6 | /tests/**/depends 7 | /tests/**/output 8 | /tests/failures 9 | -------------------------------------------------------------------------------- /B2T2/B2T2.idr: -------------------------------------------------------------------------------- 1 | module B2T2 2 | 3 | import public B2T2.ExamplePrograms 4 | import public B2T2.ExampleTables 5 | 6 | %default total 7 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/MalformedTables/MissingCell.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.MalformedTables.MissingCell 2 | 3 | import Data.Table 4 | 5 | failing "While processing right hand side of students. Sorry, I can't find any elaboration which works. All errors:" 6 | ||| Similarly to the missingRow example, as a row with two Strings 7 | ||| does not type-check against the given schema, Idris 2 tries all 8 | ||| the other uses of SnocList notation in scope, in case one of 9 | ||| them works. 10 | ||| 11 | ||| As none of them do, this fails at compile-time, with the above 12 | ||| error message. 13 | students : Table [<"name" :! String, "age" :! Nat, "favorite color" :! String] 14 | students = [< 15 | [<"Bob", "blue" ], 16 | [<"Alice", 17, "green"], 17 | [<"Eve", 13, "red" ] 18 | ] 19 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/MalformedTables/MissingRow.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.MalformedTables.MissingRow 2 | 3 | import Data.Table 4 | 5 | failing "While processing right hand side of students. Sorry, I can't find any elaboration which works. All errors:" 6 | ||| The empty row is represented as `[<]`, using the Idris 2 7 | ||| SnocList notation. 8 | ||| 9 | ||| As the empty row does not type-check in a Table with a 10 | ||| non-empty schema, Idris 2 tries all the other uses of SnocList 11 | ||| notation in scope as well, in case one of them works. 12 | ||| 13 | ||| As none of them do, this fails at compile-time, with the above 14 | ||| error message. 15 | students : Table [<"name" :! String, "age" :! Nat, "favorite color" :! String] 16 | students = [< 17 | [<"Bob", 12, "blue" ], 18 | [<"Alice", 17, "green"], 19 | [<] 20 | ] 21 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/MalformedTables/MissingSchema.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.MalformedTables.MissingSchema 2 | 3 | import Data.Table 4 | 5 | failing "Can't find an implementation for Show (Table [<(?name :! String), (?name :! Integer), (?name :! String)])." 6 | ||| While we cannot express a Table without a schema, we can 7 | ||| express a Table without an *explicit* schema. 8 | ||| 9 | ||| In the following example, we use the function call 10 | ||| `the (Table _)`to tell Idris 2 that the following expression is 11 | ||| a Table, without telling it the schema. 12 | ||| 13 | ||| We then call `show` on this Table, which requires a `Show` 14 | ||| interface for it. 15 | ||| 16 | ||| But the default `Show` interface for a Table requires its 17 | ||| schema. So this fails at compile-time, with the above error 18 | ||| message. 19 | ||| 20 | ||| Note that Idris 2 can infer much of the schema, with the 21 | ||| column names (the `?name` holes) being the only thing it cannot 22 | ||| infer. 23 | main : IO () 24 | main = putStrLn $ show $ the (Table _) [< 25 | [<"Bob", 12, "blue" ], 26 | [<"Alice", 17, "green"], 27 | [<"Eve", 13, "red" ] 28 | ] 29 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/MalformedTables/SchemaTooLong.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.MalformedTables.SchemaTooLong 2 | 3 | import Data.Table 4 | 5 | failing "While processing right hand side of students. Sorry, I can't find any elaboration which works. All errors:" 6 | ||| Similarly to the missingRow, missingCell, and schemaTooShort 7 | ||| examples, a row with three elements does not type-check against 8 | ||| a schema with four entries. So Idris 2 tries all other uses of 9 | ||| SnocList notation in scope, in case one of them works. 10 | ||| 11 | ||| As none of them do, this fails at compile-time, with the above 12 | ||| error message. 13 | students : Table [<"name" :! String, "age" :! Nat, "favorite number" :! Nat, "favorite color" :! String] 14 | students = [< 15 | [<"Bob", 12, "blue" ], 16 | [<"Alice", 17, "green"], 17 | [<"Eve", 13, "red" ] 18 | ] 19 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/MalformedTables/SchemaTooShort.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.MalformedTables.SchemaTooShort 2 | 3 | import Data.Table 4 | 5 | failing "While processing right hand side of students. Sorry, I can't find any elaboration which works. All errors:" 6 | ||| Similarly to the missingRow and missingCell examples, a row 7 | ||| with three elements does not type-check against a schema with 8 | ||| two entries. So Idris 2 tries all other uses of SnocList 9 | ||| notation in scope, in case one of them works. 10 | ||| 11 | ||| As none of them do, this fails at compile-time, with the above 12 | ||| error message. 13 | students : Table [<"name" :! String, "age" :! Nat] 14 | students = [< 15 | [<"Bob", 12, "blue" ], 16 | [<"Alice", 17, "green"], 17 | [<"Eve", 13, "red" ] 18 | ] 19 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/MalformedTables/SwappedColumns.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.MalformedTables.SwappedColumns 2 | 3 | import Data.Table 4 | 5 | failing "While processing right hand side of students. Can't find an implementation for FromString Nat." 6 | ||| Idris 2 attempts to check the types of the cells against the 7 | ||| schema, starting at the lower-right. 8 | ||| 9 | ||| The cell `"red"` type-checks ok, but it then tries to check 10 | ||| that `"Eve"` is a Nat, as required by the schema. 11 | ||| 12 | ||| As Idris 2 allows overloading of String literals, it attempts 13 | ||| to find an overload of String literals that can produce a Nat. 14 | ||| 15 | ||| As no such overload exists, this fails at compile-time, with 16 | ||| the above error message. 17 | students : Table [<"name" :! String, "age" :! Nat, "favorite color" :! String] 18 | students = [< 19 | [<12, "Bob", "blue" ], 20 | [<17, "Alice", "green"], 21 | [<13, "Eve", "red" ] 22 | ] 23 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/UsingTables/BlackAndWhite.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.UsingTables.BlackAndWhite 2 | 3 | import Data.Table 4 | 5 | import B2T2.ExampleTables 6 | 7 | failing "Can't find an implementation for Field" 8 | ||| Similarly to the midFinal example, the string literal 9 | ||| `"black and white"` fails to type-check, as Idris 2 proof 10 | ||| search fails to find a column of that name in the schema of 11 | ||| `jellyAnon`. 12 | ||| 13 | ||| So this example fails at compile-time. 14 | jellyBW : Table [< 15 | "get acne" :! Bool, 16 | "red" :! Bool, 17 | "black" :! Bool, 18 | "white" :! Bool, 19 | "green" :! Bool, 20 | "yellow" :! Bool, 21 | "brown" :! Bool, 22 | "orange" :! Bool, 23 | "pink" :! Bool, 24 | "purple" :! Bool, 25 | "eat black and white" :! Bool 26 | ] 27 | jellyBW = buildColumn "eat black and white" (\rec => value "black and white" rec == True) jellyAnon 28 | 29 | ||| As both `"black"` and `"white"` *are* in the schema of 30 | ||| `jellyAnon`, and with the right types, this example type-checks 31 | ||| successfully. 32 | jellyBW : Table [< 33 | "get acne" :! Bool, 34 | "red" :! Bool, 35 | "black" :! Bool, 36 | "white" :! Bool, 37 | "green" :! Bool, 38 | "yellow" :! Bool, 39 | "brown" :! Bool, 40 | "orange" :! Bool, 41 | "pink" :! Bool, 42 | "purple" :! Bool, 43 | "eat black and white" :! Bool 44 | ] 45 | jellyBW = buildColumn "eat black and white" (\rec => value "black" rec && value "white" rec) jellyAnon 46 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/UsingTables/BrownGetAcne.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.UsingTables.BrownGetAcne 2 | 3 | import Data.Table 4 | 5 | import B2T2.ExampleTables 6 | 7 | count : Ord a 8 | => Field schema name a 9 | -> Table schema 10 | -> Table [<"value" :! a, "count" :! Nat] 11 | 12 | failing "Can't find an implementation for Field" 13 | brownAndGetAcneTable : Table [< 14 | "name" :! String, 15 | "get acne" :! Bool, 16 | "red" :! Bool, 17 | "black" :! Bool, 18 | "white" :! Bool, 19 | "green" :! Bool, 20 | "yellow" :! Bool, 21 | "brown" :! Bool, 22 | "orange" :! Bool, 23 | "pink" :! Bool, 24 | "purple" :! Bool, 25 | "part2" :! Bool 26 | ] 27 | brownAndGetAcneTable = buildColumn "part2" (\rec => value "brown" rec && value "get acne" rec) jellyNamed 28 | 29 | ||| Similarly to the midFinal example, the string literal 30 | ||| `"brown and get acne"` fails to type-check, as Idris 2 proof 31 | ||| search fails to find a column of that name in the schema of 32 | ||| brownAndGetAcneTable. So this example fails at compile-time. 33 | result : Table [<"value" :! Bool, "count" :! Nat] 34 | result = count "brown and get acne" brownAndGetAcneTable 35 | 36 | brownAndGetAcneTable : Table [< 37 | "name" :! String, 38 | "get acne" :! Bool, 39 | "red" :! Bool, 40 | "black" :! Bool, 41 | "white" :! Bool, 42 | "green" :! Bool, 43 | "yellow" :! Bool, 44 | "brown" :! Bool, 45 | "orange" :! Bool, 46 | "pink" :! Bool, 47 | "purple" :! Bool, 48 | "brown and get acne" :! Bool 49 | ] 50 | brownAndGetAcneTable = buildColumn "brown and get acne" (\rec => value "brown" rec && value "get acne" rec) jellyNamed 51 | 52 | ||| Once the name of the new column in brownAndGetAcneTable is 53 | ||| corrected, this example type-checks successfully. 54 | result : Table [<"value" :! Bool, "count" :! Nat] 55 | result = count "brown and get acne" brownAndGetAcneTable 56 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/UsingTables/BrownJellyBeans.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.UsingTables.BrownJellyBeans 2 | 3 | import Data.Table 4 | 5 | import B2T2.ExampleTables 6 | 7 | failing "Can't find an implementation for Field schema \"color\" Bool." 8 | ||| Similarly to the midFinal example, the string literal 9 | ||| `"color"` fails to type-check, as Idris 2 proof search fails to 10 | ||| find a column of that name in the schema. 11 | ||| 12 | ||| So this example fails at compile-time. 13 | countParticipants : Field schema color Bool 14 | -> Table schema 15 | -> Nat 16 | countParticipants color tbl = fst $ length $ filter (value "color") tbl 17 | 18 | ||| Referring instead to the `Field` variable, this example 19 | ||| type-checks successfully. 20 | countParticipants : Field schema color Bool 21 | -> Table schema 22 | -> Nat 23 | countParticipants color tbl = fst $ length $ filter (value color) tbl 24 | 25 | result : Nat 26 | result = countParticipants "brown" jellyAnon 27 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/UsingTables/EmployeeToDepartment.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.UsingTables.EmployeeToDepartment 2 | 3 | import Data.Table 4 | 5 | 0 6 | Department : Schema 7 | Department = [<"Department ID" :! Nat, "Department Name" :! String] 8 | 9 | 0 10 | Employee : Schema 11 | Employee = [<"Last Name" :! String, "Department ID" :! Maybe Nat] 12 | 13 | failing "Can't find an implementation for Field Department \"Last Name\" String." 14 | ||| To implement the type-signature of `lastNameToDeptId`, we need 15 | ||| to specify what sort of table we're using. 16 | ||| 17 | ||| If we specify a `Department` table, then, similarly to the 18 | ||| midFinal example, the string literal `"Last Name"` fails to 19 | ||| type-check, as Idris 2 proof search fails to find a column of 20 | ||| that name in `Department`. 21 | ||| 22 | ||| So this example fails at compile-time. 23 | ||| 24 | ||| Misusing one sort of table as another is harder to hide when 25 | ||| you have to specify what sort of table you're using in the 26 | ||| type. 27 | lastNameToDeptId : Table Department 28 | -> (name : String) 29 | -> Maybe Nat 30 | lastNameToDeptId deptTab name = value "Department ID" <$> matchedRow 31 | where 32 | matchName : Record Department -> Bool 33 | matchName rec = value "Last Name" rec == name 34 | 35 | matchedTab : Table Department 36 | matchedTab = filter matchName deptTab 37 | 38 | matchedRow : Maybe (Record Department) 39 | matchedRow = case length matchedTab of 40 | (0 ** _) => Nothing 41 | (S _ ** _) => Just $ row matchedTab 0 42 | 43 | failing "Mismatch between: Table (Employee :< (?name :! ?type)) and Maybe String." 44 | ||| Suppose we somehow have a working `lastNameToDeptId`. 45 | lastNameToDeptId : Table Department 46 | -> (name : String) 47 | -> Maybe Nat 48 | 49 | ||| Similarly to the previous example, we need to specify the 50 | ||| expected return type of `employeeToDepartment` to implement 51 | ||| its type-signature. 52 | ||| 53 | ||| As the type returned by `buildColumn` does not match the 54 | ||| expected `Maybe String`, this example fails at compile-time. 55 | employeeToDepartment : (name : String) 56 | -> (emplTab : Table Employee) 57 | -> (deptTab : Table Department) 58 | -> Maybe String 59 | employeeToDepartment name emplTab deptTab = buildColumn "Department Name" (\rec => lastNameToDeptId deptTab $ value "Last Name" rec) emplTab 60 | 61 | failing "Mismatch between: Nat and String." 62 | ||| Suppose we somehow have a working `lastNameToDeptId`. 63 | lastNameToDeptId : Table Department 64 | -> (name : String) 65 | -> Maybe Nat 66 | 67 | ||| If we intended `employeeToDepartment` to return an `Employee` 68 | ||| table with an additional `Maybe String` column called 69 | ||| `"Department Name"`, we could indicate this by a return type of 70 | ||| `Table (Employee :< ("Department Name" :! Maybe String))`. 71 | ||| 72 | ||| This example also fails at compile-time, due to the type 73 | ||| mismatch between the expected `Maybe String` required for the 74 | ||| `buildColumn`, and the `Maybe Nat` produced by 75 | ||| `lastNameToDeptId`. 76 | employeeToDepartment : (name : String) 77 | -> (emplTab : Table Employee) 78 | -> (deptTab : Table Department) 79 | -> Table (Employee :< ("Department Name" :! Maybe String)) 80 | employeeToDepartment name emplTab deptTab = buildColumn "Department Name" (\rec => lastNameToDeptId deptTab $ value "Last Name" rec) emplTab 81 | 82 | ||| As both `"Department Name"` and `"Department ID"` are in 83 | ||| `Department`, with the right types, this example type-checks 84 | ||| successfully. 85 | deptIdToDeptName : (deptTab : Table Department) 86 | -> (deptId : Nat) 87 | -> Maybe String 88 | deptIdToDeptName deptTab deptId = value "Department Name" <$> matchedRow 89 | where 90 | matchName : Record Department -> Bool 91 | matchName rec = value "Department ID" rec == deptId 92 | 93 | matchedTab : Table Department 94 | matchedTab = filter matchName deptTab 95 | 96 | matchedRow : Maybe (Record Department) 97 | matchedRow = case length matchedTab of 98 | (0 ** _) => Nothing 99 | (S _ ** _) => Just $ row matchedTab 0 100 | 101 | ||| As this example returns the right type, this example 102 | ||| type-checks successfully. 103 | employeeToDepartment : (name : String) 104 | -> (emplTab : Table Employee) 105 | -> (deptTab : Table Department) 106 | -> Maybe String 107 | employeeToDepartment name emplTab deptTab = deptIdToDeptName deptTab !deptId 108 | where 109 | matchName : Record Employee -> Bool 110 | matchName rec = value "Last Name" rec == name 111 | 112 | matchedTab : Table Employee 113 | matchedTab = filter matchName emplTab 114 | 115 | matchedRow : Maybe (Record Employee) 116 | matchedRow = case length matchedTab of 117 | (0 ** _) => Nothing 118 | (S _ ** _) => Just $ row matchedTab 0 119 | 120 | deptId : Maybe Nat 121 | deptId = value "Department ID" !matchedRow 122 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/UsingTables/FavoriteColor.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.UsingTables.FavoriteColor 2 | 3 | import Data.Table 4 | 5 | failing "Mismatch between: String and Bool." 6 | ||| The table `filter` function expects its inner function to 7 | ||| return a Bool, but the `"favorite color"` field is a String. 8 | ||| 9 | ||| So this example fails to type-check at compile-time. 10 | ||| 11 | ||| Idris 2 then attempts to try all other `filter` functions in 12 | ||| scope, resulting in an elaboration error, as none of them work. 13 | participantsLikeGreen : Field schema "favorite color" String 14 | => Table schema 15 | -> Table schema 16 | participantsLikeGreen = filter $ \rec => value "favorite color" rec 17 | 18 | ||| When the inner function instead returns a Bool, this example 19 | ||| type-checks successfully. 20 | participantsLikeGreen : Field schema "favorite color" String 21 | => Table schema 22 | -> Table schema 23 | participantsLikeGreen = filter $ \rec => value "favorite color" rec == "green" 24 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/UsingTables/GetOnlyRow.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.UsingTables.GetOnlyRow 2 | 3 | import Data.Table 4 | 5 | import B2T2.ExampleTables 6 | 7 | failing "Can't find an implementation for So (with block in integerLessThanNat 1 False 1)." 8 | ||| The `row` function requires a proof that the given index is in 9 | ||| range for that table. 10 | ||| 11 | ||| As the table `students` is known at compile-time, Idris 2 is 12 | ||| able to work out that the result of the filter has one row. 13 | ||| 14 | ||| To try and generate the proof that the index `1` is in range, 15 | ||| Idris 2 needs a proof that `index < rowCount`. Which in this 16 | ||| case, is a proof that `1 < 1`. 17 | ||| 18 | ||| As Idris 2 cannot find such a proof, this example fails at 19 | ||| compile-time. 20 | aliceFavoriteColor : String 21 | aliceFavoriteColor = value "favorite color" $ row (filter (\student => value "name" student == "Alice") students) 1 22 | 23 | ||| In this example, Idris 2 instead needs a proof that `0 < 1`, 24 | ||| which it is able to generate automatically. 25 | ||| 26 | ||| So this example type-checks successfully. 27 | aliceFavoriteColor : String 28 | aliceFavoriteColor = value "favorite color" $ row (filter (\student => value "name" student == "Alice") students) 0 29 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/UsingTables/MidFinal.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.UsingTables.MidFinal 2 | 3 | import Data.Table 4 | 5 | import B2T2.ExampleTables 6 | 7 | data Image : Type where [external] 8 | 9 | scatterPlot : Field schema name1 Nat 10 | -> Field schema name2 Nat 11 | -> Table schema 12 | -> Image 13 | 14 | failing "Can't find an implementation for Field" 15 | ||| A `Field schema name type` object is a constructive proof that 16 | ||| a field called `name` of type `type` exists in `schema`. 17 | ||| 18 | ||| For convenience, we overload the Idris 2 string literal 19 | ||| notation to attempt to create a `Field` of that name. 20 | ||| 21 | ||| As `"mid"` is not a column in the schema of `gradebook`, 22 | ||| Idris 2 proof search fails to find such a Field, so this 23 | ||| example fails type-checking, at compile-time. 24 | img : Image 25 | img = scatterPlot "mid" "final" gradebook 26 | 27 | ||| As both `"midterm"` and `"final"` *are* in the schema of 28 | ||| `gradebook`, and with the right types, this example type-checks 29 | ||| successfully. 30 | img : Image 31 | img = scatterPlot "midterm" "final" gradebook 32 | -------------------------------------------------------------------------------- /B2T2/B2T2/Errors/UsingTables/PieCount.idr: -------------------------------------------------------------------------------- 1 | module B2T2.Errors.UsingTables.PieCount 2 | 3 | import Data.Table 4 | 5 | import B2T2.ExampleTables 6 | 7 | count : Ord a 8 | => Field schema name a 9 | -> Table schema 10 | -> Table [<"value" :! a, "count" :! Nat] 11 | 12 | data Image : Type where [external] 13 | 14 | pieChart : Ord key 15 | => Field schema name1 key 16 | -> Field schema name2 Nat 17 | -> Table schema 18 | -> Image 19 | 20 | failing "Can't find an implementation for Field" 21 | ||| Similarly to the midFinal example, the string literals 22 | ||| `"true"` and `"get acne"` fail to type-check, as Idris 2 proof 23 | ||| search fails to find columns of those names in the schema of 24 | ||| the table returned by `count`. So this example fails at 25 | ||| compile-time. 26 | img : Image 27 | img = pieChart "true" "get acne" $ count "get acne" jellyAnon 28 | 29 | ||| As both `"value"` and `"count"` *are* in the schema of the 30 | ||| table returned by `count`, and the types of these columns 31 | ||| satisfy the additional constraints required by `pieChart`, 32 | ||| this example type-checks successfully. 33 | img : Image 34 | img = pieChart "value" "count" $ count "get acne" jellyAnon 35 | -------------------------------------------------------------------------------- /B2T2/B2T2/ExamplePrograms.idr: -------------------------------------------------------------------------------- 1 | module B2T2.ExamplePrograms 2 | 3 | import public B2T2.ExamplePrograms.DotProduct 4 | import public B2T2.ExamplePrograms.GroupBy 5 | import public B2T2.ExamplePrograms.PHacking 6 | import public B2T2.ExamplePrograms.QuizScoreFilter 7 | import public B2T2.ExamplePrograms.QuizScoreSelect 8 | import public B2T2.ExamplePrograms.SampleRows 9 | 10 | %default total 11 | -------------------------------------------------------------------------------- /B2T2/B2T2/ExamplePrograms/DotProduct.idr: -------------------------------------------------------------------------------- 1 | module B2T2.ExamplePrograms.DotProduct 2 | 3 | import public Data.Table 4 | 5 | %default total 6 | 7 | public export 8 | dot : Num a 9 | => Field schema c1 a 10 | -> Field schema c2 a 11 | -> Table schema 12 | -> a 13 | dot f1 f2 [<] = 0 14 | dot f1 f2 (tbl :< rec) = dot f1 f2 tbl + value f1 rec * value f2 rec 15 | -------------------------------------------------------------------------------- /B2T2/B2T2/ExamplePrograms/GroupBy.idr: -------------------------------------------------------------------------------- 1 | module B2T2.ExamplePrograms.GroupBy 2 | 3 | import public Data.Table 4 | import Data.SortedMap 5 | 6 | import B2T2.ExampleTables 7 | 8 | %default total 9 | 10 | export 11 | groupByGeneral : Field schema keyCol a 12 | -> Ord a 13 | => (Record schema -> Record groupSchema) 14 | -> Table schema 15 | -> Table [<"key" :! a, "groups" :! Table groupSchema] 16 | groupByGeneral keyFld f tbl = mapToTable $ foldr addRow empty tbl 17 | where 18 | addVal : k -> v -> SortedMap k (List v) -> SortedMap k (List v) 19 | addVal key val map = insert key (val :: maybe [] id (lookup key map)) map 20 | 21 | addRow : Record schema -> SortedMap a (List $ Record groupSchema) -> SortedMap a (List $ Record groupSchema) 22 | addRow rec = addVal (value keyFld rec) (f rec) 23 | 24 | mapToTable : SortedMap a (List $ Record groupSchema) -> Table [<"key" :! a, "groups" :! Table groupSchema] 25 | mapToTable map = mkTable $ Prelude.map (\(key, recs) => [ Field schema keyCol a 30 | -> Table schema 31 | -> Table [<"key" :! a, "groups" :! Table schema] 32 | groupByRetentive keyFld = groupByGeneral keyFld id 33 | 34 | export 35 | groupedEmployeesRetentive : Table [<"key" :! Maybe Nat, "groups" :! Table [<"Last Name" :! String, "Department ID" :! Maybe Nat]] 36 | groupedEmployeesRetentive = groupByRetentive "Department ID" employees 37 | 38 | export 39 | groupBySubtractive : Ord a 40 | => (keyFld : Field schema keyCol a) 41 | -> Table schema 42 | -> Table [<"key" :! a, "groups" :! Table (drop schema keyFld)] 43 | groupBySubtractive keyFld = groupByGeneral keyFld (dropField keyFld) 44 | 45 | export 46 | groupedEmployeesSubtractive : Table [<"key" :! Maybe Nat, "groups" :! Table [<"Last Name" :! String]] 47 | groupedEmployeesSubtractive = groupBySubtractive "Department ID" employees 48 | -------------------------------------------------------------------------------- /B2T2/B2T2/ExamplePrograms/PHacking.idr: -------------------------------------------------------------------------------- 1 | module B2T2.ExamplePrograms.PHacking 2 | 3 | import public Data.Table 4 | import public B2T2.ExamplePrograms.PHacking.FisherTest 5 | 6 | import B2T2.ExampleTables 7 | 8 | %default total 9 | 10 | public export 11 | fisherTest : Field schema c1 Bool 12 | -> Field schema c2 Bool 13 | -> Table schema 14 | -> Double 15 | fisherTest f1 f2 tbl = pValue $ contingencySquare f1 f2 tbl 16 | where 17 | contingencySquare : Field schema c1 Bool 18 | -> Field schema c2 Bool 19 | -> Table schema 20 | -> ContingencySquare 21 | contingencySquare f1 f2 tbl = concat $ map (\rec => contingency (value f1 rec) (value f2 rec)) tbl 22 | 23 | export 24 | pHacking : {schema : Schema} 25 | -> (0 _ : AllColumns schema Bool) 26 | => {baseCol : String} 27 | -> Field schema baseCol Bool 28 | -> Table schema 29 | -> IO () 30 | pHacking baseFld tbl = do 31 | for_ (allColumns schema) $ \(name ** fld) => if name == baseCol 32 | then pure () 33 | else if fisherTest baseFld fld tbl < 0.05 34 | then putStrLn "We found a link between \{name} jelly beans and acne (p < 0.05)" 35 | else putStrLn "We found no link between \{name} jelly beans and acne (p > 0.05)" 36 | 37 | export 38 | pHackingHomogeneous : IO () 39 | pHackingHomogeneous = pHacking "get acne" jellyAnon 40 | 41 | export 42 | pHackingHeterogeneous : IO () 43 | pHackingHeterogeneous = pHacking "get acne" $ dropColumn "name" jellyNamed 44 | -------------------------------------------------------------------------------- /B2T2/B2T2/ExamplePrograms/PHacking/FisherTest.idr: -------------------------------------------------------------------------------- 1 | module B2T2.ExamplePrograms.PHacking.FisherTest 2 | 3 | %default total 4 | 5 | ||| A 2x2 contingency table 6 | public export 7 | record ContingencySquare where 8 | constructor MkContingencySquare 9 | a : Nat 10 | b : Nat 11 | c : Nat 12 | d : Nat 13 | 14 | %name ContingencySquare sqr 15 | 16 | public export 17 | contingency : Bool -> Bool -> ContingencySquare 18 | contingency False False = MkContingencySquare 1 0 0 0 19 | contingency False True = MkContingencySquare 0 1 0 0 20 | contingency True False = MkContingencySquare 0 0 1 0 21 | contingency True True = MkContingencySquare 0 0 0 1 22 | 23 | public export 24 | Semigroup ContingencySquare where 25 | x <+> y = MkContingencySquare (x.a + y.a) (x.b + y.b) (x.c + y.c) (x.d + y.d) 26 | 27 | public export 28 | Monoid ContingencySquare where 29 | neutral = MkContingencySquare 0 0 0 0 30 | 31 | public export 32 | pValue : ContingencySquare -> Double 33 | pValue (MkContingencySquare a b c d) = go a b c d 34 | where 35 | go : Nat -> Nat -> Nat -> Nat -> Double 36 | go 0 0 c d = 1 37 | go 0 (S b) c d = (cast $ S b + d) / (cast $ S b + c + d) * go 0 b c d 38 | go (S a) b c d = (cast $ S a + b) / (cast $ S a) * (cast $ S a + c) / (cast $ S a + b + c + d) * go a b c d 39 | -------------------------------------------------------------------------------- /B2T2/B2T2/ExamplePrograms/QuizScoreFilter.idr: -------------------------------------------------------------------------------- 1 | module B2T2.ExamplePrograms.QuizScoreFilter 2 | 3 | import public Data.String 4 | import public Data.Table 5 | 6 | import B2T2.ExampleTables 7 | 8 | %default total 9 | 10 | public export 11 | data GradebookColumn : (fs : FieldSchema) -> Type -> Type where [search fs] 12 | QuizCol : So (isPrefixOf "quiz" name) -> GradebookColumn (name :! a) a 13 | NoQuizCol : So (not $ isPrefixOf "quiz" name) -> GradebookColumn (name :! type) a 14 | 15 | public export 16 | GradebookSchema : Schema -> Type -> Type 17 | GradebookSchema schema a = All (`GradebookColumn` a) schema 18 | 19 | public export 20 | quizCount : (0 schema : Schema) 21 | -> GradebookSchema schema a 22 | => Nat 23 | quizCount [<] @{[<]} = 0 24 | quizCount (schema :< _) @{_ :< QuizCol _} = S $ quizCount schema 25 | quizCount (schema :< _) @{_ :< NoQuizCol _} = quizCount schema 26 | 27 | public export 28 | quizTotal : GradebookSchema schema a 29 | => Num a 30 | => Record schema 31 | -> a 32 | quizTotal @{[<]} [<] = 0 33 | quizTotal @{_ :< QuizCol _} (rec :< quizScore) = quizTotal rec + quizScore 34 | quizTotal @{_ :< NoQuizCol _} (rec :< _) = quizTotal rec 35 | 36 | public export 37 | quizAverage : GradebookSchema schema Nat 38 | => Record schema 39 | -> Double 40 | quizAverage rec = (cast $ quizTotal rec) / (cast $ quizCount schema) 41 | 42 | export 43 | gradebookWithAverage : Table [< 44 | "name" :! String, 45 | "age" :! Nat, 46 | "quiz1" :! Nat, 47 | "quiz2" :! Nat, 48 | "midterm" :! Nat, 49 | "quiz3" :! Nat, 50 | "quiz4" :! Nat, 51 | "final" :! Nat, 52 | "average-quiz" :! Double 53 | ] 54 | gradebookWithAverage = buildColumn "average-quiz" quizAverage gradebook 55 | -------------------------------------------------------------------------------- /B2T2/B2T2/ExamplePrograms/QuizScoreSelect.idr: -------------------------------------------------------------------------------- 1 | module B2T2.ExamplePrograms.QuizScoreSelect 2 | 3 | import public Data.Table 4 | 5 | import B2T2.ExampleTables 6 | 7 | %default total 8 | 9 | public export 10 | data HasQuizzes : (schema : Schema) -> (n : Nat) -> (a : Type) -> Type where [search schema n] 11 | Lin : HasQuizzes schema 0 a 12 | (:<) : HasQuizzes schema n a -> Field schema ("quiz" ++ cast (S n)) a -> HasQuizzes schema (S n) a 13 | 14 | public export 15 | quizTotal : (0 n : Nat) 16 | -> HasQuizzes schema n a 17 | => Num a 18 | => Record schema 19 | -> a 20 | quizTotal 0 @{[<]} rec = 0 21 | quizTotal (S n) @{_ :< fld} rec = quizTotal n rec + value fld rec 22 | 23 | public export 24 | quizAverage : (n : Nat) 25 | -> HasQuizzes schema n Nat 26 | => Record schema 27 | -> Double 28 | quizAverage n rec = (cast $ quizTotal n rec) / cast n 29 | 30 | export 31 | gradebookWithAverage : Table [< 32 | "name" :! String, 33 | "age" :! Nat, 34 | "quiz1" :! Nat, 35 | "quiz2" :! Nat, 36 | "midterm" :! Nat, 37 | "quiz3" :! Nat, 38 | "quiz4" :! Nat, 39 | "final" :! Nat, 40 | "average-quiz" :! Double 41 | ] 42 | gradebookWithAverage = buildColumn "average-quiz" (quizAverage 4) gradebook 43 | -------------------------------------------------------------------------------- /B2T2/B2T2/ExamplePrograms/SampleRows.idr: -------------------------------------------------------------------------------- 1 | module B2T2.ExamplePrograms.SampleRows 2 | 3 | import Data.Fin.Extra 4 | 5 | import public B2T2.ExamplePrograms.SampleRows.Probability 6 | import B2T2.ExampleTables 7 | 8 | %default total 9 | 10 | export 11 | sampleRows : HasIO io 12 | => {n : Nat} 13 | -> (frm : Frame schema n) 14 | -> (k : Fin (S n)) 15 | -> io (Frame schema (cast k)) 16 | sampleRows frm FZ = pure [<] 17 | sampleRows {n = n@(S _)} frm k@(FS j) = case strengthen' j of 18 | Left Refl => pure $ 19 | replace {p = Frame _} (cong S $ sym finToNatLastIsBound) 20 | frm 21 | Right (j' ** prf) => case !(cast k `in_` n) of 22 | False => 23 | replace {p = io . Frame _} (cong S $ sym prf) $ 24 | sampleRows (init frm) (FS j') 25 | True => 26 | [| sampleRows (init frm) j :< (pure $ last frm) |] 27 | -------------------------------------------------------------------------------- /B2T2/B2T2/ExamplePrograms/SampleRows/Probability.idr: -------------------------------------------------------------------------------- 1 | module B2T2.ExamplePrograms.SampleRows.Probability 2 | 3 | import System.Random 4 | 5 | %default total 6 | 7 | export 8 | coin : HasIO io => {default 0.5 pHead : Double} -> io Bool 9 | coin = map (< pHead) randomIO 10 | 11 | -- True with probability k in n 12 | export 13 | in_ : HasIO io => Nat -> Nat -> io Bool 14 | in_ k n = coin {pHead = cast k / cast n} 15 | -------------------------------------------------------------------------------- /B2T2/B2T2/ExampleTables.idr: -------------------------------------------------------------------------------- 1 | module B2T2.ExampleTables 2 | 3 | import public Data.Table 4 | import public Data.Vect 5 | 6 | %default total 7 | 8 | public export 9 | students : Table [<"name" :! String, "age" :! Nat, "favorite color" :! String] 10 | students = [< 11 | [<"Bob", 12, "blue" ], 12 | [<"Alice", 17, "green"], 13 | [<"Eve", 13, "red" ] 14 | ] 15 | 16 | public export 17 | studentsMissing : Table [<"name" :! String, "age" :! Maybe Nat, "favorite color" :! Maybe String] 18 | studentsMissing = [< 19 | [<"Bob", Nothing, Just "blue" ], 20 | [<"Alice", Just 17, Just "green"], 21 | [<"Eve", Just 13, Nothing ] 22 | ] 23 | 24 | public export 25 | employees : Table [<"Last Name" :! String, "Department ID" :! Maybe Nat] 26 | employees = [< 27 | [<"Rafferty", Just 31], 28 | [<"Jones", Just 32], 29 | [<"Heisenberg", Just 33], 30 | [<"Robinson", Just 34], 31 | [<"Smith", Just 34], 32 | [<"Williams", Nothing] 33 | ] 34 | 35 | public export 36 | departments : Table [<"Department ID" :! Nat, "Department Name" :! String] 37 | departments = [< 38 | [<31, "Sales" ], 39 | [<33, "Engineering"], 40 | [<34, "Clerical" ], 41 | [<35, "Marketing" ] 42 | ] 43 | 44 | public export 45 | jellyAnon : Table [< 46 | "get acne" :! Bool, 47 | "red" :! Bool, 48 | "black" :! Bool, 49 | "white" :! Bool, 50 | "green" :! Bool, 51 | "yellow" :! Bool, 52 | "brown" :! Bool, 53 | "orange" :! Bool, 54 | "pink" :! Bool, 55 | "purple" :! Bool 56 | ] 57 | jellyAnon = [< 58 | [ Q. What is the URL of the version of the benchmark being used? 4 | 5 | https://github.com/brownplt/B2T2/tree/v1.0 6 | 7 | > Q. On what date was this version of the datasheet last updated? 8 | 9 | 2022-06-07 10 | 11 | > Q. If you are not using the latest benchmark available on that date, please explain why not. 12 | 13 | N/A 14 | 15 | ## Example Tables 16 | 17 | Sample implementations of all the B2T2 Example Tables may be found in [B2T2/ExampleTables.idr](B2T2/ExampleTables.idr). 18 | 19 | > Q. Do tables express heterogeneous data, or must data be homogenized? 20 | 21 | Tables can express heterogeneous data. Each column may be any Idris 2 type. 22 | 23 | For example: 24 | 25 | ```idris 26 | Table [<"name" :! String, "age" :! Nat, "favorite color" :! String] 27 | ``` 28 | 29 | This is the type for a table with three columns, called `"name"`, `"age"`, and `"favorite color"`. 30 | The types of these columns are `String`, `Nat`, and `String`, respectively. 31 | 32 | > Q. Do tables capture missing data and, if so, how? 33 | 34 | Columns may use the `Maybe` type to allow missing data. 35 | As this is a per-column constraint, programmers may indicate which columns allow missing data. 36 | 37 | This enforces handling of potentially missing values, with no extra complexity for required values. 38 | 39 | For example, in a table of type: 40 | 41 | ```idris 42 | Table [<"name" :! String, "age" :! Maybe Nat, "favorite color" :! Maybe String] 43 | ``` 44 | 45 | The column `"name"` is required, while `"age"` and `"favorite color"` may be missing. 46 | 47 | > Q. Are mutable tables supported? Are there any limitations? 48 | 49 | All objects in Idris 2 are immutable, so mutable tables are not supported. 50 | 51 | Standard functional programming idioms can be used to imitate mutation. 52 | With the right optimizations, these idioms will even be compiled down to the use of mutation. 53 | These idioms then enforce correctness even if the schema of a table changes over its lifetime. 54 | 55 | > You may reference, instead of duplicating, the responses to the above questions in answering those below: 56 | 57 | > Q. Which tables are inexpressible? Why? 58 | 59 | All the B2T2 Example Tables may be fully expressed. 60 | 61 | > Q. Which tables are only partially expressible? Why, and what’s missing? 62 | 63 | All the B2T2 Example Tables may be fully expressed. 64 | 65 | We do not support types of columns to depend on the values in other columns (called "dependant-column tables", as opposed to "simple-column tables"). 66 | 67 | For example: 68 | 69 | ```lua 70 | | name | age | quizzes completed | quizzes | midterm | final | 71 | | ------- | --- | ----------------- | ------------ | ------- | ----- | 72 | | "Bob" | 12 | 4 | [8, 9, 7, 9] | 77 | 87 | 73 | | "Alice" | 17 | 3 | [6, 8, 7] | 88 | 85 | 74 | | "Eve" | 13 | 3 | [9, 8, 8] | 84 | 77 | 75 | ``` 76 | 77 | We cannot express, in the table type, that the length of `quizzes`, is equal to the value in `quizzes completed`. 78 | However, this may be expressed by the use of an additional proof type. 79 | 80 | In the above example, if we encode `quizzes` as a `List Nat`, in a `Table` called `tbl`, then we can encode this column dependency as the following proof type on `tbl`: 81 | 82 | ```idris 83 | AllRows (\rec => value "quizzes completed" rec = length (value "quizzes" rec)) tbl 84 | ``` 85 | 86 | More generally, for arbitrary indexed types, we can use the `Exists` type. 87 | In the above example, we could do this by instead encoding `quizzes` as an `Exists (\n => Vect n Nat)`. 88 | That is, there is some length `n`, such that `quizzes` is a list of that length. 89 | We can then link the columns together with the following proof type: 90 | 91 | ```idris 92 | AllRows (\rec => value "quizzes completed" rec = fst (value "quizzes" rec)) tbl 93 | ``` 94 | 95 | > Q. Which tables’ expressibility is unknown? Why? 96 | 97 | All simple-column tables are expressible. 98 | All dependant-column tables are indirectly expressible, through the use of the `AllRows` type, as in the previous question. 99 | 100 | > Q. Which tables can be expressed more precisely than in the benchmark? How? 101 | 102 | In the `gradebookSeq` example, we may state the type of the `"quizzes"` column to be either `List Nat`, or `Vect 4 Nat`. 103 | Using `Vect 4 Nat` says that all students must have completed exactly four exams. 104 | For `List Nat`, we are instead saying that students may have different numbers of quiz results (perhaps some students may have missed some exams). 105 | 106 | For example, the following table could be expressed by the `quizzes` column being of type `List Nat`, but not `Vect 4 Nat`. 107 | 108 | ```lua 109 | | name | age | quizzes | midterm | final | 110 | | ------- | --- | ------------ | ------- | ----- | 111 | | "Bob" | 12 | [8, 9, 7, 9] | 77 | 87 | 112 | | "Alice" | 17 | [6, 8, 7] | 88 | 85 | 113 | | "Eve" | 13 | [9, 8, 8] | 84 | 77 | 114 | ``` 115 | 116 | > Q. How direct is the mapping from the tables in the benchmark to representations in your system? How complex is the encoding? 117 | 118 | The B2T2 example tables map directly to `Table`s in our library. 119 | 120 | The names of columns may be any Idris 2 `String`, and the types may be any Idris 2 `Type`. 121 | Further, tables may be written using Idris 2's `SnocList` notation, for convenience of `Table` literals. 122 | 123 | For example: 124 | 125 | ```idris 126 | students : Table [<"name" :! String, "age" :! Nat, "favorite color" :! String] 127 | students = [< 128 | [<"Bob", 12, "blue" ], 129 | [<"Alice", 17, "green"], 130 | [<"Eve", 13, "red" ] 131 | ] 132 | ``` 133 | 134 | is an encoding of the table 135 | 136 | ```lua 137 | | name | age | favorite color | 138 | | ------- | --- | -------------- | 139 | | "Bob" | 12 | "blue" | 140 | | "Alice" | 17 | "green" | 141 | | "Eve" | 13 | "red" | 142 | ``` 143 | 144 | ## TableAPI 145 | 146 | > Q. Are there consistent changes made to the way the operations are represented? 147 | 148 | Operations are encoded as Idris 2 functions. 149 | 150 | Both "requires" and "ensures" constraints of an operation are encoded in the type of the function, where possible. 151 | Some constraints are encoded as additional proof objects about the function. 152 | 153 | > Q. Which operations are entirely inexpressible? Why? 154 | 155 | All B2T2 Table API operations are expressible. 156 | 157 | > Q. Which operations are only partially expressible? Why, and what’s missing? 158 | 159 | For simplicity, we chose not to enforce uniqueness of column names. 160 | While possible to encode in Idris 2, the proofs relating to uniqueness are quite fiddly. 161 | Further, this requirement does not provide much benefit, as Idris 2 proof inference can help disambiguate. 162 | 163 | For example, with a table `tbl` of type: 164 | 165 | ```idris 166 | Table [<"x" :! Nat, "x" :! String] 167 | ``` 168 | 169 | If we call `column "x" tbl` in a context that requires a `Nat` column, then Idris 2 will infer that we meant the first column. 170 | Similarly, if we call `column "x" tbl` in a context that requires a `String` column, then Idris 2 will infer that we meant the second column. 171 | 172 | On the other hand, if we call `column "x" tbl` in a context where either would work, then this will be a compile-time error, due to ambiguity. 173 | In this case, we can refer to the column instead by index, or disambiguate manually, by constructing the appropriate proof object. 174 | 175 | > Q. Which operations’ expressibility is unknown? Why? 176 | 177 | All B2T2 Table API operations are expressible. 178 | 179 | > Q. Which operations can be expressed more precisely than in the benchmark? How? 180 | 181 | We allow `emptyTable` to have any schema (including the empty schema). 182 | It is often useful to have an empty table of any particular schema. 183 | 184 | For example, both 185 | 186 | ```lua 187 | | name | age | favorite color | 188 | | ---- | --- | -------------- | 189 | ``` 190 | 191 | and 192 | 193 | ```lua 194 | | name | age | quizzes | midterm | final | 195 | | ---- | --- | ------- | ------- | ----- | 196 | ``` 197 | 198 | are empty tables, but have different, non-empty, schemas. 199 | 200 | As an example of where this is useful, we can define 201 | 202 | ``` 203 | values(rs) = addRows(emptyTable, rs) 204 | ``` 205 | 206 | to convert a sequence of rows into a table. 207 | This requires that the `emptyTable` have the same schema as all the given rows. 208 | 209 | Further, our version of `values` does not require that `rs` is non-empty. 210 | Instead, we get the schema of the resultant table from the type of the sequence passed in. 211 | 212 | The operations that handle missing values, we restrict to only those columns that allow missing values. 213 | 214 | ## Example Programs 215 | 216 | Sample implementations of all the B2T2 Example Programs may be found in [B2T2/ExamplePrograms](B2T2/ExamplePrograms). 217 | 218 | > Q. Which examples are inexpressible? Why? 219 | 220 | All B2T2 Example Programs are expressible. 221 | 222 | > Q. Which examples’ expressibility is unknown? Why? 223 | 224 | All B2T2 Example Programs are expressible. 225 | 226 | > Q. Which examples, or aspects thereof, can be expressed especially precisely? How? 227 | 228 | All the sample implementations use dependent types to enforce constraints at compile-time. 229 | 230 | The [`dotProduct`](B2T2/ExamplePrograms/DotProduct.idr) example has type-signature: 231 | 232 | ```idris 233 | dot : Num a 234 | => Field schema c1 a 235 | -> Field schema c2 a 236 | -> Table schema 237 | -> a 238 | ``` 239 | 240 | We enforce that the two used columns, and the result, are of the same type by repeated use of `a` in the type-signature. 241 | Further, we enforce that `a` is numeric by the constraint `Num a`. 242 | 243 | The [`sampleRows`](B2T2/ExamplePrograms/SampleRows.idr) example has type-signature: 244 | 245 | ```idris 246 | sampleRows : HasIO io 247 | => {n : Nat} 248 | -> (frm : Frame schema n) 249 | -> (k : Fin (S n)) 250 | -> io (Frame schema (cast k)) 251 | ``` 252 | 253 | We use the terminology that a `Frame schema n` is a `Table schema`, with precisely `n` rows. 254 | 255 | This function samples `k` rows from a table with `n` rows. 256 | We enforce that `k <= n`, by making `k` of type `Fin (S n)`. 257 | Further, we enforce that the resultant table has exactly `k` rows, as this table is a `Frame schema (cast k)`. 258 | 259 | The computation is done in an `io` monad, to handle randomness. 260 | 261 | The [`pHacking`](B2T2/ExamplePrograms/PHacking.idr) examples have type-signature: 262 | 263 | ```idris 264 | pHacking : {schema : Schema} 265 | -> (0 _ : AllColumns schema Bool) 266 | => {baseCol : String} 267 | -> Field schema baseCol Bool 268 | -> Table schema 269 | -> IO () 270 | ``` 271 | 272 | The constraint `AllColumns schema Bool` enforces all columns of the `schema` to be `Bool`s. 273 | 274 | The Idris 2 type-system is powerful enough to handle the `pHackingHeterogeneous` example with no further programmer code. 275 | 276 | That is, the following type-checks: 277 | 278 | ```idris 279 | pHacking "get acne" $ dropColumn "name" jellyNamed 280 | ``` 281 | 282 | The [`quizScoreFilter`](B2T2/ExamplePrograms/QuizScoreFilter.idr) example, uses the custom proof types: 283 | 284 | ```idris 285 | data GradebookColumn : (fs : FieldSchema) -> Type -> Type where [search fs] 286 | QuizCol : So (isPrefixOf "quiz" name) -> GradebookColumn (name :! a) a 287 | NoQuizCol : So (not $ isPrefixOf "quiz" name) -> GradebookColumn (name :! type) a 288 | 289 | GradebookSchema : Schema -> Type -> Type 290 | GradebookSchema schema a = All (`GradebookColumn` a) schema 291 | ``` 292 | 293 | The `GradebookSchema schema a` type enforces that all columns in `schema` whose names begin with `"quiz"` are of type `a`. 294 | This is how we explain the link between column names and types to the compiler. 295 | We use this for type-safe iteration over the columns of "gradebook" tables. 296 | 297 | The [`quizScoreSelect`](B2T2/ExamplePrograms/QuizScoreSelect.idr) example, uses the custom proof type: 298 | 299 | ```idris 300 | data HasQuizzes : (schema : Schema) -> (n : Nat) -> (a : Type) -> Type where [search schema n] 301 | Lin : HasQuizzes schema 0 a 302 | (:<) : HasQuizzes schema n a -> Field schema ("quiz" ++ cast (S n)) a -> HasQuizzes schema (S n) a 303 | ``` 304 | 305 | Similarly to the `quizScoreFilter` example, the `HasQuizzes schema n a` type proves that `schema` has at least `n` `"quiz"` columns, of type `a`. 306 | This is how we explain the link between column names and types to the compiler. 307 | We use this for type-safe selection of our `"quiz"` columns. 308 | 309 | The [`groupBy`](B2T2/ExamplePrograms/GroupBy.idr) examples are based off a single function, of type-signature: 310 | 311 | ```idris 312 | groupByGeneral : Field schema keyCol a 313 | -> Ord a 314 | => (Record schema -> Record groupSchema) 315 | -> Table schema 316 | -> Table [<"key" :! a, "groups" :! Table groupSchema] 317 | ``` 318 | 319 | We specialize on the argument that takes a function. 320 | For `groupByRetentive`, we pass in `id`, the identity function. 321 | For `groupBySubtractive`, we pass in `dropField keyFld`, to drop the key column. 322 | 323 | These versions of `groupBy` also match the constraints defined in the Table API. 324 | 325 | > Q. How direct is the mapping from the pseudocode in the benchmark to representations in your system? How complex is the encoding? 326 | 327 | Most of the examples would be written differently to how they are written in the B2T2 Example Programs, to work naturally in Idris 2. 328 | While it is possible to write these functions in the style presented in the Example Programs, we would also need a number of auxiliary lemmas to prove correctness. 329 | Our implementations are idiomatic approaches to these problems in Idris 2, where correctness is proved by construction. 330 | A programmer familiar with Idris 2 would instinctively write these functions in a similar style. 331 | 332 | The `dotProduct` example was expressed recursively, in the standard functional style. 333 | 334 | The `sampleRows` example was the most fiddly, requiring use of the Idris 2 built-in `replace` function to prove that the resultant table had the right number of rows. 335 | This example was also expressed recursively, as it was written without a built-in `sample` on lists available. 336 | 337 | The `pHacking` examples were written without pulling the columns into separate variables, to avoid having to prove that they are the same length. 338 | 339 | The `quizScoreFilter` example constructed an additional proof-type to iterate over the columns in a type-safe way, rather than use `filter`. 340 | 341 | The `quizScoreSelect` example constructed an additional proof-type to select the columns in a type-safe way, rather than use `map`. 342 | 343 | The `groupBy` examples were written with the Idris 2 `SortedMap` type, for simplicity. 344 | 345 | ## Errors 346 | 347 | Sample implementations of all the B2T2 example Errors may be found in [B2T2/Errors](B2T2/Errors). 348 | 349 | These implementations use the Idris 2 `failing` block, which type-checks only when its contents does *not* type-check. 350 | We do this to ensure that these errors are caught by the type-checker. 351 | 352 | > There are (at least) two parts to errors: representing the source program that causes the error, and generating output that explains it. The term “error situation” refers to a representation of the cause of the error in the program source. 353 | > 354 | > For each error situation it may be that the language: 355 | > 356 | > - isn’t expressive enough to capture it 357 | > - can at least partially express the situation 358 | > - prevents the program from being constructed 359 | > 360 | > Expressiveness, in turn, can be for multiple artifacts: 361 | > 362 | > - the buggy versions of the programs 363 | > - the correct variants of the programs 364 | > - the type system’s representation of the constraints 365 | > - the type system’s reporting of the violation 366 | 367 | > Q. Which error situations are known to be inexpressible? Why? 368 | 369 | All B2T2 example Errors are expressible syntactically in Idris 2. 370 | 371 | All B2T2 example Error buggy programs are rejected by the Idris 2 type-checker. 372 | 373 | > Q. Which error situations are only partially expressible? Why, and what’s missing? 374 | 375 | All B2T2 example Errors are expressible syntactically in Idris 2. 376 | 377 | All B2T2 example Error buggy programs are rejected by the Idris 2 type-checker. 378 | 379 | > Q. Which error situations’ expressibility is unknown? Why? 380 | 381 | All B2T2 example Errors are expressible syntactically in Idris 2. 382 | 383 | All B2T2 example Error buggy programs are rejected by the Idris 2 type-checker. 384 | 385 | > Q. Which error situations can be expressed more precisely than in the benchmark? How? 386 | 387 | The introduction of type-signatures require programmers to be more explicit in how functions behave. 388 | This allows us to pin down more precisely where errors occur. 389 | 390 | For example, in the `brownGetAcne` example, we could argue that the error is creating a column with the wrong name, or reading a column with the wrong name. 391 | In the type-signature of `brownAndGetAcneTable`, we can specify whether the new column should be called `"part2"`, or `"brown and get acne"`. 392 | In the former case, the error is when we try to use a column that doesn't exist in the `count`. 393 | In the latter case, the error is when we try to use `buildColumn` to construct a column with the wrong name. 394 | 395 | Similarly, in the `employeeToDepartment` example, we can specify whether `lastNameToDeptId` takes an employee table, or a department table. 396 | In the former case, the error is when we attempt to call it with a department table. 397 | In the latter case, the error is when we try to access the `"Last Name"` field of a department table. 398 | 399 | > Q. Which error situations are prevented from being constructed? How? 400 | 401 | All B2T2 example Error buggy programs are rejected by the Idris 2 type-checker. 402 | 403 | All B2T2 example Error corrected programs compile successfully. 404 | 405 | > Q. For each error situation that is at least partially expressible, what is the quality of feedback to the programmer? 406 | 407 | The error messages may be unclear to programmers unfamiliar with dependently typed programming. 408 | 409 | The issues with the Malformed Tables examples are mostly elaboration errors. 410 | As `Table` literals are written using `SnocList` notation, Idris 2 attempts to find a usage of that notation that works. 411 | As the example is incorrect, the `Table` `SnocList` notation doesn't work. 412 | Naturally, the other `SnocList` notations also don't work, as we want a `Table`. 413 | 414 | As Idris 2 does not distinguish "near miss" errors, it reports *all* `SnocList` notations in scope, saying what went wrong when it tried each of them. 415 | This can be overwhelming for programmers unfamiliar with these sorts of error messages. 416 | 417 | The issues with the Using Tables examples are mostly proof-search errors. 418 | In particular, most of them are failures to find `Field` objects. 419 | 420 | To call table operations that use a particular field, you need to prove that field is in the table. 421 | You do this by providing a `Field schema name type` object, which is an index for a field called `name` of type `type` in schema `schema`. 422 | If the schema is known at compile-time, then Idris 2 can generate these objects automatically. 423 | 424 | At least, it can when the field exists in the schema. 425 | If the field does not exist in the schema, the proof-search will fail, and Idris 2 will report that it "`Can't find an implementation for Field ...`". 426 | This can be confusing for programmers unfamiliar with proof-search, as they may not find it obvious how some sort of "implementation" is related to asking for a field that doesn't exist. 427 | 428 | Once they are familiar with this, however, the error message is useful, as it goes on to report the schema it was using, the name it was looking for, and the type it was expecting. 429 | 430 | > Q. For each error situation that is prevented from being constructed, what is the quality of feedback to the programmer? 431 | 432 | See previous question. 433 | -------------------------------------------------------------------------------- /B2T2/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: install b2t2 clean 2 | 3 | install: b2t2 4 | idris2 --install b2t2.ipkg 5 | 6 | b2t2: B2T2/build/ttc/B2T2.ttc 7 | 8 | B2T2/build/ttc/B2T2.ttc: b2t2.ipkg B2T2.idr B2T2/* B2T2/*/* B2T2/*/*/* depends 9 | idris2 --build b2t2.ipkg 10 | 11 | depends: 12 | mkdir "depends" 13 | ln -s "$(CURDIR)/../build/ttc" "$@/table-0" 14 | 15 | clean: 16 | $(RM) -r build depends 17 | -------------------------------------------------------------------------------- /B2T2/b2t2.ipkg: -------------------------------------------------------------------------------- 1 | package b2t2 2 | 3 | sourcedir = "." 4 | 5 | depends = contrib, table 6 | 7 | modules = 8 | B2T2, 9 | B2T2.Errors.MalformedTables.MissingCell, 10 | B2T2.Errors.MalformedTables.MissingRow, 11 | B2T2.Errors.MalformedTables.MissingSchema, 12 | B2T2.Errors.MalformedTables.SchemaTooLong, 13 | B2T2.Errors.MalformedTables.SchemaTooShort, 14 | B2T2.Errors.MalformedTables.SwappedColumns, 15 | B2T2.Errors.UsingTables.BlackAndWhite, 16 | B2T2.Errors.UsingTables.BrownGetAcne, 17 | B2T2.Errors.UsingTables.BrownJellyBeans, 18 | B2T2.Errors.UsingTables.EmployeeToDepartment, 19 | B2T2.Errors.UsingTables.FavoriteColor, 20 | B2T2.Errors.UsingTables.GetOnlyRow, 21 | B2T2.Errors.UsingTables.MidFinal, 22 | B2T2.Errors.UsingTables.PieCount, 23 | B2T2.ExamplePrograms, 24 | B2T2.ExamplePrograms.DotProduct, 25 | B2T2.ExamplePrograms.GroupBy, 26 | B2T2.ExamplePrograms.PHacking, 27 | B2T2.ExamplePrograms.PHacking.FisherTest, 28 | B2T2.ExamplePrograms.QuizScoreFilter, 29 | B2T2.ExamplePrograms.QuizScoreSelect, 30 | B2T2.ExamplePrograms.SampleRows, 31 | B2T2.ExamplePrograms.SampleRows.Probability, 32 | B2T2.ExampleTables 33 | -------------------------------------------------------------------------------- /Data/Table.idr: -------------------------------------------------------------------------------- 1 | module Data.Table 2 | 3 | import public Data.Table.Column 4 | import public Data.Table.Data 5 | import public Data.Table.Record 6 | import public Data.Table.Row 7 | import public Data.Table.Schema 8 | import public Data.Table.Show 9 | 10 | %default total 11 | -------------------------------------------------------------------------------- /Data/Table/Column.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Column 2 | 3 | import public Data.SnocList 4 | 5 | import public Data.Table.Column.Homogeneous 6 | import public Data.Table.Data 7 | import public Data.Table.Row 8 | 9 | %default total 10 | 11 | public export 12 | column : Field schema name type 13 | -> Table schema 14 | -> SnocList type 15 | column fld tbl = map (value fld) tbl 16 | 17 | public export 18 | selectColumns : Subschema subschema schema 19 | -> Table schema 20 | -> Table subschema 21 | selectColumns ss = map (selectFields ss) 22 | 23 | public export 24 | addColumn : (0 name : String) 25 | -> (col : SnocList type) 26 | -> (tbl : Table schema) 27 | -> {auto 0 nRows : HasRows tbl (length col)} 28 | -> Table (schema :< name :! type) 29 | addColumn name [<] [<] {nRows = EmptyTable} = [<] 30 | addColumn name (col :< x) (tbl :< rec) {nRows = SnocTable _} = addColumn name col tbl :< (rec :< x) 31 | 32 | public export 33 | renameColumns : (rs : RenameSchema schema) 34 | -> Table schema 35 | -> Table (rename schema rs) 36 | renameColumns rs = map (renameFields rs) 37 | 38 | public export 39 | replaceColumn : (fld : Field schema name type) 40 | -> (0 newName : String) 41 | -> (type -> newType) 42 | -> Table schema 43 | -> Table (replace schema fld (newName :! newType)) 44 | replaceColumn fld newName f [<] = [<] 45 | replaceColumn fld newName f (tbl :< rec) = replaceColumn fld newName f tbl :< replaceField fld newName (f $ value fld rec) rec 46 | 47 | public export 48 | updateColumn : (fld : Field schema name type) 49 | -> (type -> newType) 50 | -> Table schema 51 | -> Table (update schema fld newType) 52 | updateColumn fld f [<] = [<] 53 | updateColumn fld f (tbl :< rec) = updateColumn fld f tbl :< updateField fld f rec 54 | 55 | public export 56 | buildColumn : (0 name : String) 57 | -> (Record schema -> type) 58 | -> Table schema 59 | -> Table (schema :< name :! type) 60 | buildColumn name f tbl = 61 | let (_ ** _) = length tbl in 62 | addColumn name (map f tbl) tbl {nRows = SnocList.mapPreservesLength} 63 | 64 | public export 65 | dropColumn : (fld : Field schema name type) 66 | -> Table schema 67 | -> Table (drop schema fld) 68 | dropColumn fld tbl = mkTable $ map (dropField fld) tbl 69 | 70 | public export 71 | dropColumns : (ss : Subschema subschema schema) 72 | -> Table schema 73 | -> Table (complement schema ss) 74 | dropColumns ss = map (dropFields ss) 75 | -------------------------------------------------------------------------------- /Data/Table/Column/Homogeneous.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Column.Homogeneous 2 | 3 | import public Data.SnocList 4 | 5 | import public Data.Table.Data 6 | import public Data.Table.Schema.Quantifiers 7 | 8 | %default total 9 | 10 | public export 11 | AllColumns : Schema -> Type -> Type 12 | AllColumns schema type = AllTypes (=== type) schema 13 | 14 | public export 15 | allColumns : (schema : Schema) 16 | -> (0 _ : AllColumns schema type) 17 | => SnocList (name : String ** Field schema name type) 18 | allColumns [<] = [<] 19 | allColumns (schema :< (name :! type)) @{_ :< _} = 20 | (map (\(n ** f) => (n ** There f)) $ allColumns schema) :< (name ** here) 21 | where 22 | here : (0 _ : TypeHas (=== t1) (name :! t2)) => Field (schema :< (name :! t2)) name t1 23 | here @{TheTypeHas sameType} = replace {p = Field _ _} sameType Here 24 | -------------------------------------------------------------------------------- /Data/Table/Data.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Data 2 | 3 | import public Data.Table.Record 4 | import public Data.Table.Schema 5 | 6 | %default total 7 | 8 | public export 9 | data Table : Schema -> Type where 10 | Lin : Table schema 11 | (:<) : Table schema -> Record schema -> Table schema 12 | 13 | %name Table tbl 14 | -------------------------------------------------------------------------------- /Data/Table/Record.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Record 2 | 3 | import public Data.Table.Schema 4 | 5 | %default total 6 | 7 | public export 8 | data Record : Schema -> Type where 9 | Lin : Record [<] 10 | (:<) : Record schema -> type -> Record (schema :< (name :! type)) 11 | 12 | %name Record rec 13 | 14 | public export 15 | value : Field schema name type 16 | -> Record schema 17 | -> type 18 | value Here (rec :< x) = x 19 | value (There fld) (rec :< x) = value fld rec 20 | 21 | public export 22 | setValue : (fld : Field schema name type) 23 | -> type 24 | -> Record schema 25 | -> Record schema 26 | setValue Here x (rec :< _) = rec :< x 27 | setValue (There fld) x (rec :< y) = setValue fld x rec :< y 28 | 29 | public export 30 | selectFields : Subschema subschema schema 31 | -> Record schema 32 | -> Record subschema 33 | selectFields [<] rec = [<] 34 | selectFields (ss :< ConcatLin) (rec :< x) = selectFields ss rec :< x 35 | selectFields (ss :< ConcatSnoc c) (rec :< x) = selectFields (ss :< c) rec 36 | 37 | public export 38 | selectLeft : HasLength schema2 n 39 | => Record (schema1 ++ schema2) 40 | -> Record schema1 41 | selectLeft @{EmptySchema} rec = rec 42 | selectLeft @{SnocSchema _} (rec :< _) = selectLeft rec 43 | 44 | public export 45 | selectRight : HasLength schema2 n 46 | => Record (schema1 ++ schema2) 47 | -> Record schema2 48 | selectRight @{EmptySchema} rec = [<] 49 | selectRight @{SnocSchema _} (rec :< x) = selectRight rec :< x 50 | 51 | public export 52 | renameFields : (rs : RenameSchema schema) 53 | -> Record schema 54 | -> Record (rename schema rs) 55 | renameFields [<] rec = rec 56 | renameFields ((renames :< (_ ~> _)) @{ConcatLin}) (rec :< x) = renameFields renames rec :< x 57 | renameFields ((renames :< (oldName ~> newName)) @{ConcatSnoc _}) (rec :< x) = renameFields (renames :< (oldName ~> newName)) rec :< x 58 | 59 | public export 60 | replaceField : (fld : Field schema name type) 61 | -> (0 newName : String) 62 | -> newType 63 | -> Record schema 64 | -> Record (replace schema fld (newName :! newType)) 65 | replaceField Here newName x (rec :< _) = rec :< x 66 | replaceField (There fld) newName x (rec :< y) = replaceField fld newName x rec :< y 67 | 68 | public export 69 | setField : (fld : Field schema name type) 70 | -> newType 71 | -> Record schema 72 | -> Record (update schema fld newType) 73 | setField Here x (rec :< _) = rec :< x 74 | setField (There fld) x (rec :< y) = setField fld x rec :< y 75 | 76 | public export 77 | updateField : (fld : Field schema name type) 78 | -> (type -> newType) 79 | -> Record schema 80 | -> Record (update schema fld newType) 81 | updateField fld f rec = setField fld (f $ value fld rec) rec 82 | 83 | namespace Update 84 | infix 10 ::= 85 | 86 | public export 87 | data UpdateField : UpdateFieldSchema fs -> Type where 88 | (::=) : (0 name : String) -> type -> UpdateField (name :! type) 89 | 90 | public export 91 | data Update : UpdateSchema schema -> Type where 92 | Lin : Update [<] 93 | (:<) : Update {schema = init} us 94 | -> UpdateField {fs} ufs 95 | -> (initPrf : Concat schema (init :< fs) rest) 96 | => Update ((us :< ufs) @{initPrf}) 97 | 98 | public export 99 | updateFields : Update {schema} us 100 | -> Record schema 101 | -> Record (update schema us) 102 | updateFields [<] rec = rec 103 | updateFields ((updates :< (_ ::= x)) @{ConcatLin}) (rec :< _) = updateFields updates rec :< x 104 | updateFields ((updates :< uf@(_ ::= _)) @{ConcatSnoc _}) (rec :< y) = updateFields (updates :< uf) rec :< y 105 | 106 | public export 107 | dropField : (fld : Field schema name type) 108 | -> Record schema 109 | -> Record (drop schema fld) 110 | dropField Here (rec :< x) = rec 111 | dropField (There fld) (rec :< x) = dropField fld rec :< x 112 | 113 | public export 114 | dropFields : (ss : Subschema subschema schema) 115 | -> Record schema 116 | -> Record (complement schema ss) 117 | dropFields [<] rec = rec 118 | dropFields (ss :< ConcatLin) (rec :< x) = dropFields ss rec 119 | dropFields (ss :< ConcatSnoc c) (rec :< x) = dropFields (ss :< c) rec :< x 120 | 121 | public export 122 | (++) : Record schema1 -> Record schema2 -> Record (schema1 ++ schema2) 123 | rec1 ++ [<] = rec1 124 | rec1 ++ (rec2 :< x) = (rec1 ++ rec2) :< x 125 | 126 | public export 127 | AllTypes Eq schema => Eq (Record schema) where 128 | ([<] == [<]) @{[<]} = True 129 | ((r :< x) == (s :< y)) @{_ :< TheTypeHas _} = x == y && delay (r == s) 130 | 131 | %hint 132 | public export 133 | allTypesOrdEq : AllTypes Ord schema => AllTypes Eq schema 134 | allTypesOrdEq @{[<]} = [<] 135 | allTypesOrdEq @{_ :< TheTypeHas _} = %search :< %search 136 | 137 | public export 138 | AllTypes Ord schema => Ord (Record schema) where 139 | compare [<] [<] = EQ 140 | compare @{_ :< TheTypeHas _} (r :< x) (s :< y) = compare (r, x) (s, y) 141 | 142 | public export 143 | byField : Field schema name type 144 | -> Ord type 145 | => Eq (Record schema) 146 | => Ord (Record schema) 147 | byField fld = ByField 148 | where 149 | [ByField] Ord (Record schema) where 150 | compare = compare `on` value fld 151 | -------------------------------------------------------------------------------- /Data/Table/Row.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Row 2 | 3 | import Data.List 4 | import public Data.SnocList 5 | 6 | import public Data.Table.Data 7 | import public Data.Table.Row.Aggregate 8 | import public Data.Table.Row.Constructor 9 | import public Data.Table.Row.Frame 10 | import public Data.Table.Row.HasRows 11 | import public Data.Table.Row.Interface 12 | import public Data.Table.Row.Quantifiers 13 | 14 | %default total 15 | 16 | public export 17 | distinctBy : (Record schema -> Record schema -> Bool) -> Table schema -> Table schema 18 | distinctBy f tbl = foldl (\acc, rec => ifThenElse (elemBy f rec acc) acc (acc :< rec)) [<] $ toSnocList tbl 19 | 20 | public export 21 | distinct : Eq (Record schema) => Table schema -> Table schema 22 | distinct = distinctBy (==) 23 | 24 | public export 25 | enum : (tbl : Table schema) 26 | -> HasRows tbl n 27 | => SnocList (Fin n, Record schema) 28 | enum tbl = snd $ enum' tbl 29 | where 30 | enum' : (t : Table schema) 31 | -> HasRows t m 32 | => (Fin (S m), SnocList (Fin m, Record schema)) 33 | enum' [<] = (FZ, [<]) 34 | enum' {m = S m} (t :< rec) @{SnocTable _} = 35 | let (k, acc) = enum' t in 36 | (FS k, Prelude.map (mapFst weaken) acc :< (k, rec)) 37 | 38 | public export 39 | findIndexFromEndBy : (Record schema -> Bool) 40 | -> (tbl : Table schema) 41 | -> {auto 0 hasRows : HasRows tbl n} 42 | -> Maybe (Fin n) 43 | findIndexFromEndBy f [<] = Nothing 44 | findIndexFromEndBy f (tbl :< rec) {hasRows = SnocTable _} = 45 | if f rec 46 | then Just FZ 47 | else FS <$> findIndexFromEndBy f tbl 48 | 49 | public export 50 | findIndexBy : (Record schema -> Bool) 51 | -> (tbl : Table schema) 52 | -> HasRows tbl n 53 | => Maybe (Fin n) 54 | findIndexBy f tbl = 55 | let Val _ = length tbl in 56 | complement <$> findIndexFromEndBy f tbl 57 | 58 | public export 59 | findIndex : Eq (Record schema) 60 | => Record schema 61 | -> (tbl : Table schema) 62 | -> HasRows tbl n 63 | => Maybe (Fin n) 64 | findIndex rec = findIndexBy (== rec) 65 | 66 | export 67 | sortBy : (Record schema -> Record schema -> Ordering) -> Table schema -> Table schema 68 | sortBy cmp tbl = mkTable $ List.sortBy cmp (cast $ toSnocList tbl) 69 | 70 | export 71 | sort : Ord (Record schema) => Table schema -> Table schema 72 | sort = sortBy compare 73 | 74 | public export 75 | filter : (Record schema -> Bool) -> Table schema -> Table schema 76 | filter f tbl = do 77 | rec <- tbl 78 | case f rec of 79 | False => [<] 80 | True => pure rec 81 | 82 | public export 83 | dropNa : (fld : Field schema name (Maybe type)) 84 | -> Table schema 85 | -> Table (update schema fld type) 86 | dropNa fld tbl = do 87 | rec <- tbl 88 | case value fld rec of 89 | Nothing => [<] 90 | Just x => pure $ setField fld x rec 91 | 92 | namespace Flatten 93 | public export 94 | data Flatten : (t : Type -> Type) 95 | -> (flatSchema : Schema) 96 | -> (tSchema : Schema) 97 | -> Type where [search t tSchema] 98 | Lin : Flatten t schema schema 99 | (:<) : Flatten t f s 100 | -> Concat flatSchema (f :< (name :! type)) rest 101 | -> Concat schema (s :< (name :! t type)) rest 102 | => Flatten t flatSchema schema 103 | 104 | unroll' : Applicative t 105 | => Zippable t 106 | => Foldable t 107 | => Flatten t flatSchema schema 108 | -> Record schema 109 | -> t (Record flatSchema) 110 | unroll' [<] rec = pure rec 111 | unroll' ((fltn :< ConcatLin) @{ConcatLin}) (rec :< x) = zipWith (:<) (unroll' fltn rec) x 112 | unroll' ((fltn :< ConcatSnoc c) @{ConcatSnoc _}) (rec :< x) = (:< x) <$> unroll' (fltn :< c) rec 113 | 114 | export 115 | unroll : Applicative t 116 | => Zippable t 117 | => Foldable t 118 | => Flatten t flatSchema schema 119 | -> Record schema 120 | -> Table flatSchema 121 | unroll fltn rec = mkTable $ unroll' fltn rec 122 | 123 | export 124 | flatten : Applicative t 125 | => Zippable t 126 | => Foldable t 127 | => Flatten t flatSchema schema 128 | -> Table schema 129 | -> Table flatSchema 130 | flatten f tbl = do 131 | rec <- tbl 132 | unroll f rec 133 | -------------------------------------------------------------------------------- /Data/Table/Row/Aggregate.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Row.Aggregate 2 | 3 | import public Data.List 4 | import public Data.SnocList 5 | import public Data.SortedMap 6 | 7 | import public Data.Table.Data 8 | import public Data.Table.Row.Constructor 9 | import public Data.Table.Row.Interface 10 | import public Data.Table.Row.Quantifiers 11 | 12 | %default total 13 | 14 | export 15 | groupByFold : Ord k 16 | => (Record schema -> k) 17 | -> (Record schema -> v -> v) 18 | -> v 19 | -> Table schema 20 | -> SortedMap k v 21 | groupByFold key f initial tbl = go tbl empty 22 | where 23 | update : Record schema -> SortedMap k v -> SortedMap k v 24 | update rec vs = 25 | let key = key rec in 26 | insert key (f rec $ maybe initial id $ lookup key vs) vs 27 | 28 | go : Table schema -> SortedMap k v -> SortedMap k v 29 | go [<] acc = acc 30 | go (tbl :< rec) acc = go tbl (update rec acc) 31 | 32 | export 33 | groupBy : Ord k 34 | => (Record schema -> k) 35 | -> (Record schema -> v) 36 | -> Table schema 37 | -> SortedMap k (List v) 38 | groupBy key val tbl = groupByFold key ((::) . val) [] tbl 39 | 40 | export 41 | group : Ord a 42 | => (keyFld : Field schema keyCol a) 43 | -> Table schema 44 | -> SortedMap a (Table (drop schema keyFld)) 45 | group keyFld tbl = map mkTable $ groupBy (value keyFld) (dropField keyFld) tbl 46 | 47 | export 48 | groupMany : AllTypes Ord subschema 49 | => (ss : Subschema subschema schema) 50 | -> Table schema 51 | -> SortedMap (Record subschema) (Table (complement schema ss)) 52 | groupMany keyFld tbl = map mkTable $ groupBy (selectFields keyFld) (dropFields keyFld) tbl 53 | 54 | export 55 | groupKeepKey : Ord a 56 | => Field schema keyCol a 57 | -> Table schema 58 | -> SortedMap a (Table schema) 59 | groupKeepKey keyFld tbl = map mkTable $ groupBy (value keyFld) id tbl 60 | 61 | export 62 | groupManyKeepKeys : AllTypes Ord subschema 63 | => (ss : Subschema subschema schema) 64 | -> Table schema 65 | -> SortedMap (Record subschema) (Table schema) 66 | groupManyKeepKeys keyFld tbl = map mkTable $ groupBy (selectFields keyFld) id tbl 67 | 68 | export 69 | countBy : Ord k 70 | => (Record schema -> k) 71 | -> Table schema 72 | -> SortedMap k Nat 73 | countBy f = groupByFold f (const S) 0 74 | 75 | export 76 | count : Ord a 77 | => Field schema name a 78 | -> Table schema 79 | -> SortedMap a Nat 80 | count fld = countBy (value fld) 81 | 82 | infix 0 $$= 83 | 84 | public export 85 | data FieldAggregation : FieldSchema -> Type where 86 | ($$=) : (0 rename : RenameFieldSchema (oldName :! oldType)) -> (List oldType -> newType) -> FieldAggregation (oldName :! oldType) 87 | 88 | public export 89 | Aggregation : Schema -> Type 90 | Aggregation schema = Many FieldAggregation schema 91 | 92 | public export 93 | 0 94 | aggSchema : Aggregation schema -> Schema 95 | aggSchema [<] = [<] 96 | aggSchema ((aggs :< agg) @{c}) = case c of 97 | ConcatLin => 98 | let (_ ~> newName $$= _ ) {newType} = agg in 99 | aggSchema aggs :< (newName :! newType) 100 | ConcatSnoc d => aggSchema ((aggs :< agg) @{d}) 101 | 102 | public export 103 | 0 104 | aggOldSchema : Aggregation schema -> Schema 105 | aggOldSchema [<] = [<] 106 | aggOldSchema ((aggs :< agg) @{c}) = case c of 107 | ConcatLin => 108 | let (oldName ~> _ $$= _ ) {oldType} = agg in 109 | aggOldSchema aggs :< (oldName :! oldType) 110 | ConcatSnoc d => aggOldSchema ((aggs :< agg) @{d}) 111 | 112 | public export 113 | aggFields : (aggs : Aggregation schema) 114 | -> Record schema 115 | -> Record (aggOldSchema aggs) 116 | aggFields [<] rec = [<] 117 | aggFields ((aggs :< (_ ~> _ $$= _)) @{ConcatLin}) (rec :< x) = aggFields aggs rec :< x 118 | aggFields ((aggs :< agg) @{ConcatSnoc d}) (rec :< _) = aggFields ((aggs :< agg) @{d}) rec 119 | 120 | empties : (aggs : Aggregation schema) => AllTypes List (aggOldSchema aggs) 121 | empties @{[<]} = [<] 122 | empties @{(aggs :< (_ ~> _ $$= _)) @{ConcatLin}} = empties @{aggs} :< TheTypeHas [] 123 | empties {schema = _ :< (_ :! _)} @{(aggs :< agg) @{ConcatSnoc d}} = empties @{(aggs :< agg) @{d}} 124 | 125 | (::) : Record schema -> AllTypes List schema -> AllTypes List schema 126 | [<] :: [<] = [<] 127 | (rec :< x) :: (rest :< TheTypeHas col) = (rec :: rest) :< TheTypeHas (x :: col) 128 | 129 | export 130 | aggregationColumns : (aggs : Aggregation schema) 131 | -> Table schema 132 | -> AllTypes List (aggOldSchema aggs) 133 | aggregationColumns aggs tbl = Interface.foldr (::) (empties @{aggs}) (map (aggFields aggs) tbl) 134 | 135 | export 136 | aggregateColumns : (aggs : Aggregation schema) 137 | -> AllTypes List (aggOldSchema aggs) 138 | -> Record (aggSchema aggs) 139 | aggregateColumns [<] [<] = [<] 140 | aggregateColumns ((aggs :< (_ ~> _ $$= f)) @{ConcatLin}) (cols :< TheTypeHas col) = aggregateColumns aggs cols :< f col 141 | aggregateColumns {schema = _ :< (_ :! _)} ((aggs :< agg) @{ConcatSnoc c}) x = aggregateColumns ((aggs :< agg) @{c}) x 142 | 143 | export 144 | aggregate : (aggs : Aggregation schema) 145 | -> Table schema 146 | -> Record (aggSchema aggs) 147 | aggregate aggs tbl = aggregateColumns aggs (aggregationColumns aggs tbl) 148 | 149 | export 150 | pivot : AllTypes Ord subschema 151 | => (ss : Subschema subschema schema) 152 | -> (aggs : Aggregation (complement schema ss)) 153 | -> Table schema 154 | -> Table (subschema ++ aggSchema aggs) 155 | pivot ss aggs tbl = 156 | mkTable $ 157 | map (uncurry (++)) $ 158 | SortedMap.toList $ 159 | map (aggregate aggs) $ 160 | groupMany ss tbl 161 | 162 | public export 163 | meltRec : {subschema : Schema} 164 | -> (ss : Subschema subschema schema) 165 | -> AllTypes (=== type) subschema 166 | => (0 varName : String) 167 | -> (0 valName : String) 168 | -> Record schema 169 | -> Table (complement schema ss :< (varName :! String) :< (valName :! type)) 170 | meltRec [<] varName valName rec = [<] 171 | meltRec {subschema = _ :< fs} (ss :< ConcatLin) @{_ :< hasType} varName valName rec = 172 | let TheTypeHas Refl = hasType 173 | name :! _ = fs 174 | rec :< x = rec in 175 | meltRec ss varName valName rec :< (dropFields ss rec :< name :< x) 176 | meltRec (ss :< ConcatSnoc c) varName valName (rec :< x) = 177 | map (\(xs :< n :< v) => xs :< x :< n :< v) $ 178 | meltRec (ss :< c) varName valName rec 179 | 180 | public export 181 | melt : {subschema : Schema} 182 | -> (ss : Subschema subschema schema) 183 | -> AllTypes (=== type) subschema 184 | => (0 varName : String) 185 | -> (0 valName : String) 186 | -> Table schema 187 | -> Table (complement schema ss :< (varName :! String) :< (valName :! type)) 188 | melt ss varName valName tbl = do 189 | rec <- tbl 190 | meltRec ss varName valName rec 191 | 192 | namespace Unmelt 193 | public export 194 | defaultUnmeltVarSchema : Table schema 195 | -> Field schema varName String 196 | -> Type 197 | -> Schema 198 | defaultUnmeltVarSchema tbl fld type = toSchema $ cast $ nub {a = String} $ cast $ map (value fld) tbl 199 | where 200 | toSchema : SnocList String -> Schema 201 | toSchema [<] = [<] 202 | toSchema (names :< name) = toSchema names :< (name :! Maybe type) 203 | 204 | public export 205 | unmelt : (tbl : Table schema) 206 | -> (varFld : Field schema varName String) 207 | -> {0 type : Type} 208 | -> {default (defaultUnmeltVarSchema tbl varFld type) 0 varSchema : Schema} 209 | -> AllRows (\rec => Field varSchema (value varFld rec) (Maybe type)) tbl 210 | => AllTypes (=== Maybe type) varSchema 211 | => HasLength varSchema n 212 | => (valFld : Field (drop schema varFld) valName type) 213 | -> Eq (Record (drop (drop schema varFld) valFld)) 214 | => Table (drop (drop schema varFld) valFld ++ varSchema) 215 | unmelt [<] varFld valFld = [<] 216 | unmelt (tbl :< rec) varFld {varSchema} @{_ :< fld} valFld = 217 | case unmelt tbl varFld {varSchema} valFld of 218 | [<] => [ if selectLeft unmeltRec == dropField valFld (dropField varFld rec) 220 | then case value (onTheRight fld) unmeltRec of 221 | Nothing => unmeltTbl :< setVar unmeltRec 222 | Just _ => unmeltTbl :< unmeltRec :< newRec 223 | else unmeltTbl :< unmeltRec :< newRec 224 | where 225 | 0 226 | ResultSchema : Schema 227 | ResultSchema = drop (drop schema varFld) valFld ++ varSchema 228 | 229 | setVar : Record ResultSchema -> Record ResultSchema 230 | setVar result = setValue (onTheRight fld) (Just $ value valFld $ dropField varFld rec) result 231 | 232 | nothings : (0 schema : Schema) 233 | -> AllTypes (=== Maybe type) schema 234 | => Record schema 235 | nothings [<] @{[<]} = [<] 236 | nothings (schema :< _) @{_ :< TheTypeHas Refl} = nothings schema :< Nothing 237 | 238 | newRec : Record ResultSchema 239 | newRec = setVar $ dropField valFld (dropField varFld rec) ++ nothings varSchema 240 | -------------------------------------------------------------------------------- /Data/Table/Row/Constructor.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Row.Constructor 2 | 3 | import public Data.Table.Data 4 | import public Data.Table.Row.HasRows 5 | import Data.Table.Row.Interface 6 | 7 | namespace FromFoldable 8 | public export 9 | mkTable : Foldable f => f (Record schema) -> Table schema 10 | mkTable = foldl (:<) [<] 11 | 12 | public export 13 | (++) : Foldable f => Table schema -> f (Record schema) -> Table schema 14 | (++) = foldl (:<) 15 | 16 | infixl 7 |+| 17 | 18 | public export 19 | (|+|) : (tbl1 : Table schema1) 20 | -> (0 nrows1 : HasRows tbl1 n) 21 | => (tbl2 : Table schema2) 22 | -> (0 nrows2 : HasRows tbl2 n) 23 | => Table (schema1 ++ schema2) 24 | ([<] |+| [<]) {nrows1 = EmptyTable} {nrows2 = EmptyTable} = [<] 25 | ((tbl1 :< rec1) |+| (tbl2 :< rec2)) {nrows1 = SnocTable _} {nrows2 = SnocTable _} = 26 | (tbl1 |+| tbl2) :< (rec1 ++ rec2) 27 | 28 | public export 29 | zipHasRows : (0 tbl1 : Table schema1) 30 | -> (nrows1 : HasRows tbl1 n) 31 | => (0 tbl2 : Table schema2) 32 | -> (nrows2 : HasRows tbl2 n) 33 | => HasRows (tbl1 |+| tbl2) n 34 | zipHasRows [<] [<] {nrows1 = EmptyTable} {nrows2 = EmptyTable} = EmptyTable 35 | zipHasRows (tbl1 :< rec1) (tbl2 :< rec2) {nrows1 = SnocTable _} {nrows2 = SnocTable _} = 36 | SnocTable $ zipHasRows tbl1 tbl2 37 | 38 | infixl 9 |*| 39 | 40 | public export 41 | (|*|) : Table schema1 -> Table schema2 -> Table (schema1 ++ schema2) 42 | tbl1 |*| tbl2 = do 43 | rec1 <- tbl1 44 | rec2 <- tbl2 45 | pure $ rec1 ++ rec2 46 | 47 | public export 48 | crossJoinHasRows : (0 tbl1 : Table schema1) 49 | -> (hasRows1 : HasRows tbl1 n1) 50 | => (0 tbl2 : Table schema2) 51 | -> (hasRows2 : HasRows tbl2 n2) 52 | => HasRows (tbl1 |*| tbl2) (n1 * n2) 53 | crossJoinHasRows tbl1 tbl2 = do 54 | _ <- tbl1 55 | replace {p = HasRows _} (multOneRightNeutral _) $ do 56 | _ <- tbl2 57 | pureHasRows 58 | -------------------------------------------------------------------------------- /Data/Table/Row/Frame.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Row.Frame 2 | 3 | import public Data.DPair 4 | 5 | import public Data.Table.Data 6 | import public Data.Table.Row.Constructor 7 | import public Data.Table.Row.HasRows 8 | 9 | %default total 10 | 11 | public export 12 | Frame : Schema -> Nat -> Type 13 | Frame schema n = Subset (Table schema) (`HasRows` n) 14 | 15 | public export 16 | Lin : Frame schema 0 17 | Lin = Element [<] EmptyTable 18 | 19 | public export 20 | (:<) : Frame schema n -> Record schema -> Frame schema (S n) 21 | (Element tbl hasRows) :< row = Element (tbl :< row) (SnocTable hasRows) 22 | 23 | public export 24 | %inline 25 | init : Frame schema (S n) -> Frame schema n 26 | init = uncurry go 27 | where 28 | go : (tbl : Table schema) -> (0 hasRows : HasRows tbl (S n)) -> Frame schema n 29 | go (tbl :< _) (SnocTable hasRows) = Element tbl hasRows 30 | 31 | public export 32 | %inline 33 | last : Frame schema (S n) -> Record schema 34 | last (Element (tbl :< row) hasRows) = row 35 | 36 | public export 37 | %inline 38 | frame : (tbl : Table schema) 39 | -> {auto 0 hasRows : HasRows tbl n} 40 | -> Frame schema n 41 | frame tbl = Element tbl hasRows 42 | 43 | public export 44 | %inline 45 | table : (frm : Frame schema n) 46 | -> Table schema 47 | table (Element tbl hasRows) = tbl 48 | 49 | public export 50 | %hint 51 | 0 52 | frameHasRows : (frm : Frame schema n) 53 | -> {0 tbl : _} 54 | -> {auto 0 ford : tbl = table frm} 55 | -> HasRows tbl n 56 | frameHasRows {ford = Refl} (Element tbl hasRows) = hasRows 57 | 58 | public export 59 | (|+|) : Frame schema1 n -> Frame schema2 n -> Frame (schema1 ++ schema2) n 60 | frm1 |+| frm2 = 61 | let 0 hasRows = zipHasRows (table frm1) (table frm2) in 62 | frame $ table frm1 |+| table frm2 63 | 64 | public export 65 | (|*|) : Frame schema1 n1 66 | -> Frame schema2 n2 67 | -> Frame (schema1 ++ schema2) (n1 * n2) 68 | frm1 |*| frm2 = 69 | let 0 hasRows = crossJoinHasRows (table frm1) (table frm2) in 70 | frame $ table frm1 |*| table frm2 71 | -------------------------------------------------------------------------------- /Data/Table/Row/HasRows.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Row.HasRows 2 | 3 | import public Data.Fin 4 | import public Data.Singleton 5 | 6 | import public Data.Table.Data 7 | 8 | %default total 9 | 10 | public export 11 | data HasRows : (tbl : Table schema) -> Nat -> Type where [search tbl] 12 | EmptyTable : HasRows [<] 0 13 | SnocTable : (hasRows : HasRows tbl n) -> HasRows (tbl :< rec) (S n) 14 | 15 | namespace Singleton 16 | public export 17 | length : (0 tbl : Table schema) -> HasRows tbl n => Singleton n 18 | length [<] @{EmptyTable} = Val 0 19 | length (tbl :< _) @{SnocTable hasRows} = [| S (length tbl) |] 20 | 21 | namespace HasRows 22 | public export 23 | length : (tbl : Table schema) -> (n : Nat ** HasRows tbl n) 24 | length [<] = (0 ** EmptyTable) 25 | length (tbl :< _) = 26 | let (m ** hasRows) = length tbl in 27 | (S m ** SnocTable hasRows) 28 | 29 | public export 30 | rowFromEnd : (tbl : Table schema) 31 | -> {auto 0 hasRows : HasRows tbl n} 32 | -> Fin n 33 | -> Record schema 34 | rowFromEnd [<] {hasRows = EmptyTable} x = absurd x 35 | rowFromEnd (tbl :< rec) FZ = rec 36 | rowFromEnd (tbl :< rec) {hasRows = SnocTable _} (FS x) = rowFromEnd tbl x 37 | 38 | public export 39 | row : (tbl : Table schema) 40 | -> HasRows tbl n 41 | => Fin n 42 | -> Record schema 43 | row tbl x = 44 | let Val _ = length tbl in 45 | rowFromEnd tbl $ complement x 46 | 47 | public export 48 | dropRows : (tbl : Table schema) 49 | -> HasRows tbl n 50 | => Fin (S n) 51 | -> Table schema 52 | dropRows [<] @{EmptyTable} FZ = [<] 53 | dropRows tbl@(_ :< _) @{SnocTable _} FZ = tbl 54 | dropRows (tbl :< _) @{SnocTable _} (FS k) = dropRows tbl k 55 | 56 | public export 57 | init : (tbl : Table schema) 58 | -> HasRows tbl n 59 | => Fin (S n) 60 | -> Table schema 61 | init tbl k = 62 | let Val _ = length tbl in 63 | dropRows tbl $ complement k 64 | -------------------------------------------------------------------------------- /Data/Table/Row/Interface.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Row.Interface 2 | 3 | import Data.Nat 4 | import Data.DPair 5 | import Data.SnocList 6 | 7 | import public Data.Table.Data 8 | import public Data.Table.Row.HasRows 9 | 10 | public export 11 | (++) : Table schema -> Table schema -> Table schema 12 | t ++ [<] = t 13 | t ++ (rows :< rec) = (t ++ rows) :< rec 14 | 15 | public export 16 | concatHasRows : (0 tbl1 : Table schema) 17 | -> (hasRows1 : HasRows tbl1 n1) 18 | => (0 tbl2 : Table schema) 19 | -> (hasRows2 : HasRows tbl2 n2) 20 | => HasRows (tbl1 ++ tbl2) (n1 + n2) 21 | concatHasRows tbl1 [<] {hasRows2 = EmptyTable} = 22 | replace {p = HasRows _} (sym $ plusZeroRightNeutral _) $ 23 | hasRows1 24 | concatHasRows tbl1 (tbl2 :< rec) {hasRows2 = SnocTable hasRows} = 25 | replace {p = HasRows _} (plusSuccRightSucc _ _) $ 26 | SnocTable (concatHasRows tbl1 tbl2) 27 | 28 | -- Algebra 29 | 30 | public export 31 | Semigroup (Table schema) where 32 | (<+>) = (++) 33 | 34 | public export 35 | Monoid (Table schema) where 36 | neutral = [<] 37 | 38 | -- "Functor" 39 | 40 | namespace SnocList 41 | public export 42 | map : (Record schema -> a) -> Table schema -> SnocList a 43 | map f [<] = [<] 44 | map f (tbl :< rec) = map f tbl :< f rec 45 | 46 | public export 47 | mapPreservesLength : HasRows tbl n => HasRows tbl (length (map f tbl)) 48 | mapPreservesLength @{EmptyTable} = EmptyTable 49 | mapPreservesLength @{SnocTable _} = SnocTable mapPreservesLength 50 | 51 | namespace Table 52 | public export 53 | map : (Record schema1 -> Record schema2) -> Table schema1 -> Table schema2 54 | map f [<] = [<] 55 | map f (tbl :< rec) = map f tbl :< f rec 56 | 57 | public export 58 | mapPreservesLength : HasRows tbl n => HasRows (map f tbl) n 59 | mapPreservesLength @{EmptyTable} = EmptyTable 60 | mapPreservesLength @{SnocTable _} = SnocTable Table.mapPreservesLength 61 | 62 | -- "Foldable" 63 | 64 | public export 65 | foldr : (Record schema -> a -> a) -> a -> Table schema -> a 66 | foldr f x [<] = x 67 | foldr f x (tbl :< rec) = foldr f (f rec x) tbl 68 | 69 | public export 70 | toSnocList : Table schema -> SnocList (Record schema) 71 | toSnocList [<] = [<] 72 | toSnocList (tbl :< rec) = toSnocList tbl :< rec 73 | 74 | public export 75 | elemBy : (Record schema -> Record schema -> Bool) -> Record schema -> Table schema -> Bool 76 | elemBy f rec tbl = elemBy f rec (toSnocList tbl) 77 | 78 | public export 79 | elem : Eq (Record schema) => Record schema -> Table schema -> Bool 80 | elem = elemBy (==) 81 | 82 | -- "Monad" 83 | 84 | public export 85 | pure : Record schema -> Table schema 86 | pure rec = [>=) : Table schema1 -> (Record schema1 -> Table schema2) -> Table schema2 94 | tbl >>= f = concat $ map f tbl 95 | 96 | public export 97 | bindHasRows : (tbl : Table schema1) 98 | -> (fHasRows : (rec : Record schema1) -> (Exists (HasRows (f rec)))) 99 | -> HasRows (tbl >>= f) (sum $ map (\rec => (fHasRows rec).fst) tbl) 100 | bindHasRows tbl fHasRows = partialSumHasRows tbl 101 | where 102 | partialSumHasRows : (tbl : Table schema1) 103 | -> HasRows acc accRows 104 | => HasRows (foldr (++) acc (map f tbl)) (foldr (+) accRows (map (\rec => (fHasRows rec).fst) tbl)) 105 | partialSumHasRows [<] @{accHasRows} = accHasRows 106 | partialSumHasRows (tbl :< rec) = partialSumHasRows tbl @{concatHasRows _ @{(fHasRows rec).snd} _} 107 | 108 | namespace HasRows 109 | public export 110 | (>>=) : (tbl : Table schema1) 111 | -> (fHasRows : (rec : Record schema1) -> (Exists (HasRows (f rec)))) 112 | -> HasRows (tbl >>= f) (sum $ map (\rec => (fHasRows rec).fst) tbl) 113 | (>>=) = bindHasRows 114 | 115 | public export 116 | bindConstHasRows : (0 tbl : Table schema1) 117 | -> HasRows tbl m 118 | => (fHasRows : (0 rec : Record schema1) -> HasRows (f rec) n) 119 | -> HasRows (tbl >>= f) (m * n) 120 | bindConstHasRows tbl fHasRows = 121 | replace {p = HasRows _} (plusZeroRightNeutral _) $ 122 | partialSumHasRows tbl 123 | where 124 | partialSumHasRows : (0 tbl : Table schema1) 125 | -> HasRows tbl p 126 | => HasRows acc accRows 127 | => HasRows (foldr (++) acc (map f tbl)) (p * n + accRows) 128 | partialSumHasRows [<] @{EmptyTable} @{accHasRows} = accHasRows 129 | partialSumHasRows (tbl :< rec) @{SnocTable hasRows} = 130 | replace {p = HasRows _} (trans (plusAssociative _ _ _) $ cong (+ accRows) $ plusCommutative _ _) $ 131 | partialSumHasRows tbl @{hasRows} @{concatHasRows _ _} 132 | 133 | namespace HasRowsConst 134 | public export 135 | (>>=) : (0 tbl : Table schema1) 136 | -> HasRows tbl m 137 | => (fHasRows : (0 rec : Record schema1) -> HasRows (f rec) n) 138 | -> HasRows (tbl >>= f) (m * n) 139 | (>>=) = bindConstHasRows 140 | -------------------------------------------------------------------------------- /Data/Table/Row/Quantifiers.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Row.Quantifiers 2 | 3 | import public Data.Table.Data 4 | 5 | public export 6 | data AllRows : (p : Record schema -> Type) -> Table schema -> Type where 7 | Lin : AllRows p [<] 8 | (:<) : AllRows p tbl -> p rec -> AllRows p (tbl :< rec) 9 | -------------------------------------------------------------------------------- /Data/Table/Schema.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Schema 2 | 3 | import public Data.Table.Schema.Data 4 | import public Data.Table.Schema.Index 5 | import public Data.Table.Schema.Subschema 6 | import public Data.Table.Schema.Quantifiers 7 | 8 | %default total 9 | 10 | public export 11 | onTheLeft : HasLength schema2 n 12 | => Field schema1 name type 13 | -> Field (schema1 ++ schema2) name type 14 | onTheLeft @{EmptySchema} fld = fld 15 | onTheLeft @{SnocSchema _} fld = There (onTheLeft fld) 16 | 17 | public export 18 | onTheRight : Field schema2 name type 19 | -> Field (schema1 ++ schema2) name type 20 | onTheRight Here = Here 21 | onTheRight (There fld) = There (onTheRight fld) 22 | 23 | public export 24 | fromString : (name : String) 25 | -> {auto fld : Field schema name type} 26 | -> Field schema name type 27 | fromString name = fld 28 | 29 | public export 30 | replace : (schema : Schema) 31 | -> Field schema name type 32 | -> FieldSchema 33 | -> Schema 34 | replace (schema :< (name :! type)) Here newFS = schema :< newFS 35 | replace (schema :< fs) (There fld) newFS = replace schema fld newFS :< fs 36 | 37 | namespace RenameMany 38 | infix 10 ~> 39 | 40 | public export 41 | data RenameFieldSchema : FieldSchema -> Type where 42 | (~>) : (oldName : String) -> (newName : String) -> RenameFieldSchema (oldName :! type) 43 | 44 | public export 45 | RenameSchema : Schema -> Type 46 | RenameSchema schema = Many RenameFieldSchema schema 47 | 48 | public export 49 | rename : (schema : Schema) 50 | -> RenameSchema schema 51 | -> Schema 52 | rename schema [<] = schema 53 | rename o@(schema :< fs) ((renames :< rs) @{c}) with () 54 | rename o@(schema :< (oldName :! type)) ((renames :< (oldName ~> newName)) @{ConcatLin}) | _ = rename schema renames :< (newName :! type) 55 | rename o@(schema :< fs) ((renames :< rs) @{ConcatSnoc _}) | _ = rename schema (renames :< rs) :< fs 56 | 57 | public export 58 | update : (schema : Schema) 59 | -> Field schema name type 60 | -> Type 61 | -> Schema 62 | update (schema :< (name :! type)) Here newType = schema :< (name :! newType) 63 | update (schema :< fs) (There fld) newType = update schema fld newType :< fs 64 | 65 | namespace UpdateMany 66 | public export 67 | data UpdateFieldSchema : FieldSchema -> Type where 68 | (:!) : (name : String) -> (newType : Type) -> UpdateFieldSchema (name :! oldType) 69 | 70 | public export 71 | UpdateSchema : Schema -> Type 72 | UpdateSchema schema = Many UpdateFieldSchema schema 73 | 74 | public export 75 | update : (schema : Schema) 76 | -> UpdateSchema schema 77 | -> Schema 78 | update schema [<] = schema 79 | update o@(schema :< fs) ((updates :< us) @{c}) with () 80 | update o@(schema :< (name :! oldType)) ((updates :< (name :! newType)) @{ConcatLin}) | _ = update schema updates :< (name :! newType) 81 | update o@(schema :< fs) ((updates :< us) @{ConcatSnoc _}) | _ = update schema (updates :< us) :< fs 82 | 83 | public export 84 | drop : (schema : Schema) 85 | -> Field schema name type 86 | -> Schema 87 | drop (schema :< (name :! type)) Here = schema 88 | drop (schema :< fs) (There fld) = drop schema fld :< fs 89 | -------------------------------------------------------------------------------- /Data/Table/Schema/Data.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Schema.Data 2 | 3 | %default total 4 | 5 | infix 10 :! 6 | 7 | public export 8 | data FieldSchema = (:!) String Type 9 | 10 | %name FieldSchema fs 11 | 12 | public export 13 | data Schema : Type where 14 | Lin : Schema 15 | (:<) : Schema -> FieldSchema -> Schema 16 | 17 | %name Schema schema 18 | 19 | public export 20 | names : Schema -> SnocList String 21 | names [<] = [<] 22 | names (schema :< (name :! type)) = names schema :< name 23 | 24 | public export 25 | types : Schema -> SnocList Type 26 | types [<] = [<] 27 | types (schema :< (name :! type)) = types schema :< type 28 | 29 | public export 30 | length : Schema -> Nat 31 | length [<] = 0 32 | length (schema :< _) = S (length schema) 33 | 34 | public export 35 | data Field : (schema : Schema) -> (name : String) -> Type -> Type where [uniqueSearch, search schema name] 36 | Here : Field (schema :< (name :! type)) name type 37 | There : (fld : Field schema name type) -> Field (schema :< fs) name type 38 | 39 | %name Field fld 40 | 41 | public export 42 | (++) : Schema -> Schema -> Schema 43 | schema1 ++ [<] = schema1 44 | schema1 ++ (schema2 :< fs) = (schema1 ++ schema2) :< fs 45 | -------------------------------------------------------------------------------- /Data/Table/Schema/Index.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Schema.Index 2 | 3 | import public Data.Table.Schema.Data 4 | 5 | %default total 6 | 7 | public export 8 | data HasLength : (schema : Schema) -> (n : Nat) -> Type where [search schema] 9 | EmptySchema : HasLength [<] 0 10 | SnocSchema : HasLength schema n -> HasLength (schema :< fs) (S n) 11 | 12 | %name HasLength lth 13 | 14 | public export 15 | data HasIndex : (schema : Schema) 16 | -> (fld : Field schema name type) 17 | -> (i : Nat) 18 | -> Type where [search schema i] 19 | LastIndex : HasLength (schema :< (name :! type)) (S i) -> HasIndex (schema :< (name :! type)) Here i 20 | PrevIndex : HasIndex schema fld i -> HasIndex (schema :< fs) (There fld) i 21 | 22 | %name HasIndex idx 23 | 24 | public export 25 | fromInteger : (0 x : Integer) 26 | -> {fld : Field schema name type} 27 | -> {auto 0 hasIndex : HasIndex schema fld (fromInteger x)} 28 | -> Field schema name type 29 | fromInteger x = fld 30 | -------------------------------------------------------------------------------- /Data/Table/Schema/Quantifiers.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Schema.Quantifiers 2 | 3 | import public Data.Table.Schema.Data 4 | import public Data.Table.Schema.Index 5 | 6 | namespace All 7 | public export 8 | data All : (p : FieldSchema -> Type) -> Schema -> Type where 9 | Lin : All p [<] 10 | (:<) : All p schema -> p col -> All p (schema :< col) 11 | 12 | public export 13 | length : All p schema -> Nat 14 | length [<] = 0 15 | length (all :< _) = S (length all) 16 | 17 | public export 18 | lengthAllLengthSchema : (all : All p schema) -> length all = length schema 19 | lengthAllLengthSchema [<] = Refl 20 | lengthAllLengthSchema (all :< _) = cong S (lengthAllLengthSchema all) 21 | 22 | namespace AllTypes 23 | public export 24 | data TypeHas : (p : Type -> Type) -> FieldSchema -> Type where 25 | TheTypeHas : p type -> TypeHas p (name :! type) 26 | 27 | public export 28 | AllTypes : (p : Type -> Type) -> Schema -> Type 29 | AllTypes p schema = All (TypeHas p) schema 30 | 31 | namespace Concat 32 | public export 33 | data Concat : (xs : Schema) 34 | -> (init : Schema) 35 | -> (rest : Schema) 36 | -> Type where [uniqueSearch, search xs] 37 | ConcatLin : Concat xs xs [<] 38 | ConcatSnoc : Concat xs init rest -> Concat (xs :< x) init (rest :< x) 39 | 40 | %name Concat c, d 41 | 42 | public export 43 | fromString : (name : String) 44 | -> Concat schema (init :< (name :! type)) rest 45 | => Concat schema (init :< (name :! type)) rest 46 | fromString name @{c} = c 47 | 48 | public export 49 | data Take : (xs : Schema) 50 | -> (init : Schema) 51 | -> (rest : Schema) 52 | -> (n : Nat) 53 | -> Type where [uniqueSearch, search xs] 54 | TakeAll : HasLength xs n -> Take xs xs [<] n 55 | SkipLast : Take xs init rest n -> Take (xs :< x) init (rest :< x) n 56 | 57 | %name Take tk 58 | 59 | public export 60 | fromInteger : (index : Integer) 61 | -> Take schema init rest (S $ cast index) 62 | => Concat schema init rest 63 | fromInteger index @{TakeAll _} = ConcatLin 64 | fromInteger index @{SkipLast tk} = ConcatSnoc $ fromInteger index @{tk} 65 | 66 | namespace Many 67 | public export 68 | data Many : (p : FieldSchema -> Type) -> (xs : Schema) -> Type where 69 | Lin : Many p xs 70 | (:<) : Many p init 71 | -> p x 72 | -> Concat xs (init :< x) rest 73 | => Many p xs 74 | 75 | %name Many pxs, pys, pzs 76 | -------------------------------------------------------------------------------- /Data/Table/Schema/Subschema.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Schema.Subschema 2 | 3 | import public Data.Table.Schema.Data 4 | import public Data.Table.Schema.Quantifiers 5 | 6 | %default total 7 | 8 | public export 9 | data Subschema : (subschema : Schema) -> (superschema : Schema) -> Type where [uniqueSearch, search superschema] 10 | Lin : Subschema [<] superschema 11 | (:<) : Subschema subschema init 12 | -> Concat schema (init :< fs) rest 13 | -> Subschema (subschema :< fs) schema 14 | 15 | public export 16 | complement : (schema : Schema) 17 | -> Subschema subschema schema 18 | -> Schema 19 | complement schema [<] = schema 20 | complement o@(schema :< fs) (ss :< c) with () 21 | complement o@(schema :< fs) (ss :< ConcatLin) | _ = complement schema ss 22 | complement o@(schema :< fs) (ss :< ConcatSnoc d) | _ = complement schema (ss :< d) :< fs 23 | -------------------------------------------------------------------------------- /Data/Table/Show.idr: -------------------------------------------------------------------------------- 1 | module Data.Table.Show 2 | 3 | import Data.String 4 | import public Data.Vect 5 | 6 | import Syntax.PreorderReasoning 7 | 8 | import public Data.Table.Schema.Quantifiers 9 | import public Data.Table.Data 10 | import Data.Table.Row 11 | 12 | public export 13 | ShowField : FieldSchema -> Type 14 | ShowField (_ :! type) = Show type 15 | 16 | ||| A schema whose columns are all instances of Show 17 | public export 18 | ShowSchema : Schema -> Type 19 | ShowSchema schema = All ShowField schema 20 | 21 | -- Would be natural to use a SnocVect, but stdlib doesn't have it yet 22 | showRecordAux : (acc : Vect k String) 23 | -> ShowSchema schema 24 | => Record schema 25 | -> Vect (length schema + k) String 26 | showRecordAux acc [<] = acc 27 | showRecordAux acc @{_ :< _} (rec :< fld) = 28 | replace {p = \n => Vect n String} (sym $ plusSuccRightSucc _ _) $ 29 | showRecordAux (show fld :: acc) rec 30 | 31 | showRecord : ShowSchema schema 32 | => Record schema 33 | -> Vect (length schema) String 34 | showRecord rec = 35 | replace {p = \n => Vect n String} (plusZeroRightNeutral _) $ 36 | showRecordAux [] rec 37 | 38 | nameVectAux : (acc : Vect k String) 39 | -> (schema : Schema) 40 | -> Vect (length schema + k) String 41 | nameVectAux acc [<] = acc 42 | nameVectAux acc (schema :< (name :! _)) = 43 | replace {p = \n => Vect n String} (sym $ plusSuccRightSucc _ _) $ 44 | nameVectAux (name :: acc) schema 45 | 46 | nameVect : (schema : Schema) 47 | -> Vect (length schema) String 48 | nameVect schema = 49 | replace {p = \n => Vect n String} (plusZeroRightNeutral _) $ 50 | nameVectAux [] schema 51 | 52 | ||| Pipe separated string 53 | pipeSeparate : List String -> String 54 | pipeSeparate strs = "| \{concat $ intersperse " | " $ strs} |" 55 | 56 | ||| Pipe separated ruler 57 | ruler : List Nat -> String 58 | ruler = pipeSeparate . (map $ flip replicate '-') 59 | 60 | namespace Horizontal 61 | public export 62 | data Alignment = L | R | C 63 | 64 | namespace Vertical 65 | public export 66 | data Alignment = T | B | C 67 | 68 | halign : Horizontal.Alignment -> (width : Nat) -> String -> String 69 | halign L width str = padRight width ' ' str 70 | halign R width str = padLeft width ' ' str 71 | halign C width str = let delta = cast width - (cast $ length str) in 72 | if delta <= 0 73 | then str 74 | else let lft_delta = delta `div` 2 75 | rgt_delta = delta - lft_delta 76 | in (replicate (cast lft_delta) ' ') ++ str ++ (replicate (cast rgt_delta) ' ') 77 | 78 | ||| Take first `len` elements of the list, but return how many you 79 | ||| took, and how many are left 80 | take : (len : Nat) -> List a -> (n : Nat ** m : Nat ** prf : m + n = len ** Vect n a) 81 | take 0 xs = (0 ** 0 ** Refl ** []) 82 | take len@(S _) [] = (0 ** len ** plusZeroRightNeutral _ ** []) 83 | take (S len) (x :: xs) = 84 | let (n ** m ** prf ** ys) = Show.take len xs in 85 | (S n ** m ** Calc $ 86 | |~ m + (1 + n) 87 | ~~ 1 + (m + n) ...(sym $ plusSuccRightSucc _ _) 88 | ~~ 1 + len ...(cong (1 +) prf) 89 | ** x :: ys) 90 | 91 | halve : (n : Nat) -> (small : Nat ** big : Nat ** small + big = n) 92 | halve 0 = (0 ** 0 ** Refl) 93 | halve 1 = (0 ** 1 ** Refl) 94 | halve (S $ S n) = 95 | let (small ** big ** prf) = halve n in 96 | (S small ** S big ** Calc $ 97 | |~ 1 + (small + (1 + big)) 98 | ~~ 2 + (small + big) ...(cong (1 +) $ sym $ plusSuccRightSucc _ _) 99 | ~~ 2 + n ...(cong (2 +) prf)) 100 | 101 | valign : Vertical.Alignment -> (height : Nat) -> List String -> Vect height String 102 | valign algn height xs = 103 | let (m ** n ** prf ** ys) = Show.take height xs 104 | (small ** big ** prf') : (small : Nat ** big : Nat ** small + big = n) = case algn of 105 | T => (0 ** n ** Refl) 106 | B => (n ** 0 ** plusZeroRightNeutral _) 107 | C => halve n 108 | result = (replicate small "") ++ ys ++ (replicate big "") 109 | correct = Calc $ 110 | |~ small + (m + big) 111 | ~~ small + (big + m) ...(cong (small +) $ plusCommutative _ _) 112 | ~~(small + big) + m ...(plusAssociative _ _ _) 113 | ~~ n + m ...(cong (+ m) prf') 114 | ~~ height ...(prf) 115 | in replace {p = \k => Vect k String} correct 116 | result 117 | 118 | ||| Input a vector of `n` strings, possibly containing new-lines 119 | ||| Output: One or more lines, reflowing each cell in the vector 120 | ||| according to its newlines 121 | ||| 122 | ||| Example: 123 | ||| 124 | ||| ["a\nb" , "cde", "f\n\g\n\h"] 125 | ||| 126 | ||| becomes: 127 | ||| 128 | ||| [["a" , "cde", "f"] 129 | ||| ,["b" , "" , "g"] 130 | ||| ,["" , "" , "h"] 131 | linesRow : (valignment : Vect n Vertical.Alignment) -> Vect n String -> List (Vect n String) 132 | linesRow valignment xs = 133 | let xsLines = map lines xs 134 | heights = map List.length xsLines 135 | maximal = foldr max 0 heights 136 | in toList $ transpose $ zipWith (\v => valign v maximal) valignment xsLines 137 | 138 | ||| Print 1 row in the table, 139 | printVect : (widths : Vect n Nat) 140 | -> (halignment : Vect n Horizontal.Alignment) 141 | -> Vect n String 142 | -> String 143 | printVect widths halignment entries = 144 | pipeSeparate $ toList $ 145 | zipWith3 (\algn,n,str => halign algn n str) halignment widths entries 146 | 147 | formatTable : {n : Nat} 148 | -> (header : List (Vect n String)) 149 | -> (body : SnocList (Vect n String)) 150 | -> (halignment : Vect n Horizontal.Alignment) 151 | -> (valignment : Vect n Vertical.Alignment) 152 | -> String 153 | formatTable header body halignment valignment = 154 | let header = foldMap (linesRow valignment) header 155 | rows = foldMap (linesRow valignment) body 156 | maxWidths = foldr (\xs,acc => zipWith max (map length xs) acc) 157 | (replicate _ 0) (rows ++ header) 158 | in unlines $ "" -- Empty first line makes printing alignment a little nicer 159 | :: (map (printVect maxWidths halignment) header) 160 | ++ (ruler $ toList maxWidths) 161 | :: (map (printVect maxWidths halignment) rows) 162 | 163 | export 164 | showTable : {schema : Schema} 165 | -> ShowSchema schema 166 | => {default (replicate (length schema) L) halignment : Vect (length schema) Horizontal.Alignment} 167 | -> {default (replicate (length schema) T) valignment : Vect (length schema) Vertical.Alignment} 168 | -> Table schema 169 | -> String 170 | showTable table = formatTable { 171 | n = length schema, 172 | header = [nameVect schema], 173 | body = map showRecord table, 174 | halignment, 175 | valignment 176 | } 177 | 178 | ||| If we don't have access to the schema, we can still show the body 179 | ||| of the table. 180 | export 181 | showTableBody : (allShow : ShowSchema schema) 182 | => {default (replicate (length allShow) L) halignment : Vect (length allShow) Horizontal.Alignment} 183 | -> {default (replicate (length allShow) T) valignment : Vect (length allShow) Vertical.Alignment} 184 | -> Table schema 185 | -> String 186 | -- Reconstruct the number of columns from the show instance :D 187 | showTableBody table = 188 | let rows = replace {p = \n => SnocList (Vect n String)} (sym $ lengthAllLengthSchema allShow) $ 189 | map showRecord table 190 | in formatTable { 191 | n = length allShow, 192 | header = [], 193 | body = rows, 194 | halignment, 195 | valignment 196 | } 197 | 198 | export 199 | {schema : Schema} -> ShowSchema schema => Show (Table schema) where 200 | show = showTable 201 | 202 | export 203 | showFrame : {schema : Schema} 204 | -> ShowSchema schema 205 | => {default (replicate (length schema) L) halignment : Vect (length schema) Horizontal.Alignment} 206 | -> {default (replicate (length schema) T) valignment : Vect (length schema) Vertical.Alignment} 207 | -> Frame schema n 208 | -> String 209 | showFrame frm = showTable {halignment} {valignment} $ table frm 210 | 211 | ||| If we don't have access to the schema, we can still show the body 212 | ||| of the table. 213 | export 214 | showFrameBody : (allShow : ShowSchema schema) 215 | => {default (replicate (length allShow) L) halignment : Vect (length allShow) Horizontal.Alignment} 216 | -> {default (replicate (length allShow) T) valignment : Vect (length allShow) Vertical.Alignment} 217 | -> Frame schema n 218 | -> String 219 | showFrameBody frm = showTableBody {halignment} {valignment} $ table frm 220 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022 Robert Wright 2 | School of Informatics, University of Edinburgh 3 | All rights reserved. 4 | 5 | This code is derived from software written by Robert Wright 6 | (robert.wright@ed.ac.uk). 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 3. None of the names of the copyright holders may be used to endorse 17 | or promote products derived from this software without specific 18 | prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY 21 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 23 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE 24 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 25 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 26 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 27 | BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 29 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN 30 | IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | *** End of disclaimer. *** 33 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all install table b2t2 test retest clean 2 | 3 | all: table b2t2 4 | 5 | install: table 6 | idris2 --install table.ipkg 7 | make -C B2T2 install 8 | 9 | table: build/ttc/Data/Table.ttc 10 | 11 | build/ttc/Data/Table.ttc: table.ipkg Data/Table/* Data/Table/*/* 12 | idris2 --build table.ipkg 13 | 14 | b2t2: 15 | make -C B2T2 b2t2 16 | 17 | test: 18 | make -C tests test 19 | 20 | retest: 21 | make -C tests retest 22 | 23 | clean: 24 | make -C tests clean 25 | make -C B2T2 clean 26 | $(RM) -r build 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Idris2-Table 2 | 3 | A table library for Idris 2. 4 | 5 | ## Install 6 | 7 | Run: 8 | 9 | ```bash 10 | make install 11 | ``` 12 | 13 | ## Usage 14 | 15 | Build your code with the `table` package, and import the `Data.Table` module. 16 | 17 | ### Example 18 | 19 | Examples here and in the tests are taken from [B2T2](https://blog.brownplt.org/2021/11/21/b2t2.html) benchmark examples. 20 | 21 | Tables are of type `Table schema`, where a `Schema` is a description of the columns of the table. 22 | 23 | ```idris 24 | import Data.Table 25 | 26 | gradebook : Table [<"name" :! String, "age" :! Nat, "midterm" :! Nat, "final" :! Nat] 27 | gradebook = [< 28 | [<"Bob", 12, 77, 87], 29 | [<"Alice", 17, 88, 85], 30 | [<"Eve", 13, 84, 77] 31 | ] 32 | 33 | ``` 34 | 35 | Accessing a field requires a proof that field exists in the schema. 36 | We can prove that a schema has a certain field by constructing a proof object of type `HasField schema name type`. 37 | 38 | For simple examples, Idris can find these proofs automatically: 39 | 40 | ```idris-repl 41 | Main> column "name" gradebook 42 | [<"Bob", "Alice", "Eve"] 43 | ``` 44 | 45 | For a more complicated example, you may need to construct them yourself: 46 | 47 | ```idris 48 | grades : Bool -> SnocList Nat 49 | grades getFinal = do 50 | let (fld ** prf) = the (fld : String ** HasField _ fld Nat) $ if getFinal 51 | then ("final" ** %search) 52 | else ("midterm" ** %search) 53 | column fld @{prf} gradebook 54 | ``` 55 | 56 | See [here](B2T2/B2T2/ExamplePrograms) for sample implementations of the B2T2 example programs. 57 | -------------------------------------------------------------------------------- /table.ipkg: -------------------------------------------------------------------------------- 1 | package table 2 | 3 | sourcedir = "." 4 | 5 | depends = contrib 6 | 7 | modules = 8 | Data.Table, 9 | Data.Table.Column, 10 | Data.Table.Column.Homogeneous, 11 | Data.Table.Data, 12 | Data.Table.Record, 13 | Data.Table.Row, 14 | Data.Table.Row.Aggregate, 15 | Data.Table.Row.Constructor, 16 | Data.Table.Row.Frame, 17 | Data.Table.Row.HasRows, 18 | Data.Table.Row.Interface, 19 | Data.Table.Row.Quantifiers, 20 | Data.Table.Schema, 21 | Data.Table.Schema.Data, 22 | Data.Table.Schema.Index, 23 | Data.Table.Schema.Quantifiers, 24 | Data.Table.Schema.Subschema, 25 | Data.Table.Show 26 | -------------------------------------------------------------------------------- /tests/B2T2/DotProduct/expected: -------------------------------------------------------------------------------- 1 | 183 2 | 3 | -------------------------------------------------------------------------------- /tests/B2T2/DotProduct/run: -------------------------------------------------------------------------------- 1 | . ../../testutils.sh 2 | 3 | b2t2Test << EOF 4 | dot "quiz1" "quiz2" gradebook 5 | EOF 6 | -------------------------------------------------------------------------------- /tests/B2T2/Errors/expected: -------------------------------------------------------------------------------- 1 | Imported module B2T2.Errors.MalformedTables.MissingSchema 2 | Imported module B2T2.Errors.MalformedTables.MissingRow 3 | Imported module B2T2.Errors.MalformedTables.MissingCell 4 | Imported module B2T2.Errors.MalformedTables.SwappedColumns 5 | Imported module B2T2.Errors.MalformedTables.SchemaTooShort 6 | Imported module B2T2.Errors.MalformedTables.SchemaTooLong 7 | 8 | Imported module B2T2.Errors.UsingTables.MidFinal 9 | Imported module B2T2.Errors.UsingTables.BlackAndWhite 10 | Imported module B2T2.Errors.UsingTables.PieCount 11 | Imported module B2T2.Errors.UsingTables.BrownGetAcne 12 | Imported module B2T2.Errors.UsingTables.GetOnlyRow 13 | Imported module B2T2.Errors.UsingTables.FavoriteColor 14 | Imported module B2T2.Errors.UsingTables.BrownJellyBeans 15 | Imported module B2T2.Errors.UsingTables.EmployeeToDepartment 16 | 17 | -------------------------------------------------------------------------------- /tests/B2T2/Errors/run: -------------------------------------------------------------------------------- 1 | . ../../testutils.sh 2 | 3 | b2t2Test << EOF 4 | :module B2T2.Errors.MalformedTables.MissingSchema 5 | :module B2T2.Errors.MalformedTables.MissingRow 6 | :module B2T2.Errors.MalformedTables.MissingCell 7 | :module B2T2.Errors.MalformedTables.SwappedColumns 8 | :module B2T2.Errors.MalformedTables.SchemaTooShort 9 | :module B2T2.Errors.MalformedTables.SchemaTooLong 10 | 11 | :module B2T2.Errors.UsingTables.MidFinal 12 | :module B2T2.Errors.UsingTables.BlackAndWhite 13 | :module B2T2.Errors.UsingTables.PieCount 14 | :module B2T2.Errors.UsingTables.BrownGetAcne 15 | :module B2T2.Errors.UsingTables.GetOnlyRow 16 | :module B2T2.Errors.UsingTables.FavoriteColor 17 | :module B2T2.Errors.UsingTables.BrownJellyBeans 18 | :module B2T2.Errors.UsingTables.EmployeeToDepartment 19 | EOF 20 | -------------------------------------------------------------------------------- /tests/B2T2/GroupBy/expected: -------------------------------------------------------------------------------- 1 | 2 | | key | groups | 3 | | ------- | -------------------------------- | 4 | | Nothing | | 5 | | | | Last Name | Department ID | | 6 | | | | ---------- | ------------- | | 7 | | | | "Williams" | Nothing | | 8 | | Just 31 | | 9 | | | | Last Name | Department ID | | 10 | | | | ---------- | ------------- | | 11 | | | | "Rafferty" | Just 31 | | 12 | | Just 32 | | 13 | | | | Last Name | Department ID | | 14 | | | | --------- | ------------- | | 15 | | | | "Jones" | Just 32 | | 16 | | Just 33 | | 17 | | | | Last Name | Department ID | | 18 | | | | ------------ | ------------- | | 19 | | | | "Heisenberg" | Just 33 | | 20 | | Just 34 | | 21 | | | | Last Name | Department ID | | 22 | | | | ---------- | ------------- | | 23 | | | | "Robinson" | Just 34 | | 24 | | | | "Smith" | Just 34 | | 25 | 26 | 27 | 28 | | key | groups | 29 | | ------- | ---------------- | 30 | | Nothing | | 31 | | | | Last Name | | 32 | | | | ---------- | | 33 | | | | "Williams" | | 34 | | Just 31 | | 35 | | | | Last Name | | 36 | | | | ---------- | | 37 | | | | "Rafferty" | | 38 | | Just 32 | | 39 | | | | Last Name | | 40 | | | | --------- | | 41 | | | | "Jones" | | 42 | | Just 33 | | 43 | | | | Last Name | | 44 | | | | ------------ | | 45 | | | | "Heisenberg" | | 46 | | Just 34 | | 47 | | | | Last Name | | 48 | | | | ---------- | | 49 | | | | "Robinson" | | 50 | | | | "Smith" | | 51 | 52 | 53 | -------------------------------------------------------------------------------- /tests/B2T2/GroupBy/run: -------------------------------------------------------------------------------- 1 | . ../../testutils.sh 2 | 3 | b2t2Test << EOF 4 | :exec printLn groupedEmployeesRetentive 5 | 6 | :exec printLn groupedEmployeesSubtractive 7 | EOF 8 | -------------------------------------------------------------------------------- /tests/B2T2/PHacking/expected: -------------------------------------------------------------------------------- 1 | We found no link between red jelly beans and acne (p > 0.05) 2 | We found no link between black jelly beans and acne (p > 0.05) 3 | We found no link between white jelly beans and acne (p > 0.05) 4 | We found no link between green jelly beans and acne (p > 0.05) 5 | We found no link between yellow jelly beans and acne (p > 0.05) 6 | We found no link between brown jelly beans and acne (p > 0.05) 7 | We found a link between orange jelly beans and acne (p < 0.05) 8 | We found no link between pink jelly beans and acne (p > 0.05) 9 | We found no link between purple jelly beans and acne (p > 0.05) 10 | 11 | We found no link between red jelly beans and acne (p > 0.05) 12 | We found no link between black jelly beans and acne (p > 0.05) 13 | We found no link between white jelly beans and acne (p > 0.05) 14 | We found no link between green jelly beans and acne (p > 0.05) 15 | We found no link between yellow jelly beans and acne (p > 0.05) 16 | We found no link between brown jelly beans and acne (p > 0.05) 17 | We found a link between orange jelly beans and acne (p < 0.05) 18 | We found no link between pink jelly beans and acne (p > 0.05) 19 | We found no link between purple jelly beans and acne (p > 0.05) 20 | 21 | -------------------------------------------------------------------------------- /tests/B2T2/PHacking/run: -------------------------------------------------------------------------------- 1 | . ../../testutils.sh 2 | 3 | b2t2Test << EOF 4 | :exec pHackingHomogeneous 5 | 6 | :exec pHackingHeterogeneous 7 | EOF 8 | -------------------------------------------------------------------------------- /tests/B2T2/QuizScoreFilter/expected: -------------------------------------------------------------------------------- 1 | 2 | | name | age | quiz1 | quiz2 | midterm | quiz3 | quiz4 | final | average-quiz | 3 | | ------- | --- | ----- | ----- | ------- | ----- | ----- | ----- | ------------ | 4 | | "Bob" | 12 | 8 | 9 | 77 | 7 | 9 | 87 | 8.25 | 5 | | "Alice" | 17 | 6 | 8 | 88 | 8 | 7 | 85 | 7.25 | 6 | | "Eve" | 13 | 7 | 9 | 84 | 8 | 8 | 77 | 8.0 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /tests/B2T2/QuizScoreFilter/run: -------------------------------------------------------------------------------- 1 | . ../../testutils.sh 2 | 3 | b2t2Test << EOF 4 | :exec printLn QuizScoreFilter.gradebookWithAverage 5 | EOF 6 | -------------------------------------------------------------------------------- /tests/B2T2/QuizScoreSelect/expected: -------------------------------------------------------------------------------- 1 | 2 | | name | age | quiz1 | quiz2 | midterm | quiz3 | quiz4 | final | average-quiz | 3 | | ------- | --- | ----- | ----- | ------- | ----- | ----- | ----- | ------------ | 4 | | "Bob" | 12 | 8 | 9 | 77 | 7 | 9 | 87 | 8.25 | 5 | | "Alice" | 17 | 6 | 8 | 88 | 8 | 7 | 85 | 7.25 | 6 | | "Eve" | 13 | 7 | 9 | 84 | 8 | 8 | 77 | 8.0 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /tests/B2T2/QuizScoreSelect/run: -------------------------------------------------------------------------------- 1 | . ../../testutils.sh 2 | 3 | b2t2Test << EOF 4 | :exec printLn QuizScoreSelect.gradebookWithAverage 5 | EOF 6 | -------------------------------------------------------------------------------- /tests/B2T2/SampleRows/Samples.idr: -------------------------------------------------------------------------------- 1 | import B2T2 2 | 3 | export 4 | main : IO () 5 | main = do 6 | for_ [1..300] $ \_ => do 7 | Element tbl hasRows <- sampleRows (frame students) 2 8 | printLn $ map (value "name") tbl 9 | -------------------------------------------------------------------------------- /tests/B2T2/SampleRows/expected: -------------------------------------------------------------------------------- 1 | Bob sampled reasonably 2 | Alice sampled reasonably 3 | Eve sampled reasonably 4 | -------------------------------------------------------------------------------- /tests/B2T2/SampleRows/run: -------------------------------------------------------------------------------- 1 | . ../../testutils.sh 2 | 3 | # As sampling is non-deterministic, we run a large number of iterations, and check that the counts are reasonable 4 | 5 | samples="$(echo ":exec main" | b2t2Test Samples.idr)" 6 | 7 | checkCount() { 8 | name=$1 9 | count=$(echo "$samples" | grep -c "$name" -) 10 | 11 | if [ "$count" -ge 150 ] && [ "$count" -le 250 ]; then 12 | echo "$name sampled reasonably" 13 | else 14 | echo "$name sampled $count times" 15 | fi 16 | } 17 | 18 | checkCount "Bob" 19 | checkCount "Alice" 20 | checkCount "Eve" 21 | -------------------------------------------------------------------------------- /tests/Column/ExampleTable.idr: -------------------------------------------------------------------------------- 1 | import Data.Table 2 | 3 | StudentSchema : Schema 4 | StudentSchema = [<"name" :! String, "age" :! Nat, "favorite color" :! String] 5 | 6 | students : Table StudentSchema 7 | students = [< 8 | [<"Bob", 12, "blue" ], 9 | [<"Alice", 17, "green"], 10 | [<"Eve", 13, "red" ] 11 | ] 12 | 13 | grade : Nat -> String 14 | grade n = case n `div` 10 of 15 | 10 => "A+" 16 | 9 => "A+" 17 | 8 => "A" 18 | 7 => "B" 19 | 6 => "C" 20 | 5 => "D" 21 | _ => "F" 22 | -------------------------------------------------------------------------------- /tests/Column/expected: -------------------------------------------------------------------------------- 1 | [<[<"Bob", 12, "blue"], [<"Alice", 17, "green"], [<"Eve", 13, "red"]] 2 | 3 | [<"Bob", "Alice", "Eve"] 4 | [<12, 17, 13] 5 | Error: Can't find an implementation for Field StudentSchema "grade" ?type. 6 | 7 | (Interactive):1:12--1:19 8 | 1 | column "grade" students 9 | ^^^^^^^ 10 | 11 | 12 | [<[<"Bob"], [<"Alice"], [<"Eve"]] 13 | [<[<"Bob", 12], [<"Alice", 17], [<"Eve", 13]] 14 | 15 | [<[<"Bob", 12, "blue"], [<"Alice", 17, "green"], [<"Eve", 13, "red"]] 16 | 17 | [<[<"Bob", 12, "blue", 87], [<"Alice", 17, "green", 85], [<"Eve", 13, "red", 77]] 18 | 19 | [<"Bob", "Alice", "Eve"] 20 | [<12, 17, 13] 21 | [<87, 85, 77] 22 | 23 | [<[<"Bob", 12, "blue", "A"], [<"Alice", 17, "green", "A"], [<"Eve", 13, "red", "B"]] 24 | 25 | [<[<"Bob", 12, "blue"], [<"Alice", 17, "green"], [<"Eve", 13, "red"]] 26 | 27 | [<[<"Bob", 12, "blue", 87, "A"], [<"Alice", 17, "green", 85, "A"], [<"Eve", 13, "red", 77, "B"]] 28 | 29 | [<[<"Bob", "blue"], [<"Alice", "green"], [<"Eve", "red"]] 30 | [<[<"Bob", 12], [<"Alice", 17], [<"Eve", 13]] 31 | Error: Can't find an implementation for Field StudentSchema "grade" ?type. 32 | 33 | (Interactive):1:16--1:23 34 | 1 | dropColumn "grade" students 35 | ^^^^^^^ 36 | 37 | 38 | [<[<"Bob", "blue"], [<"Alice", "green"], [<"Eve", "red"]] 39 | [<[<"Bob"], [<"Alice"], [<"Eve"]] 40 | 41 | [<("name" ** There Here), ("favorite color" ** Here)] 42 | Error: Can't find an implementation for All (TypeHas (\arg => arg = String)) [<("name" :! String), 43 | ("age" :! Nat), 44 | ("favorite color" :! String)]. 45 | 46 | (Interactive):1:5--1:29 47 | 1 | allColumns StudentSchema 48 | ^^^^^^^^^^^^^^^^^^^^^^^^ 49 | 50 | 51 | -------------------------------------------------------------------------------- /tests/Column/run: -------------------------------------------------------------------------------- 1 | . ../testutils.sh 2 | 3 | basicTest ExampleTable.idr << EOF 4 | students 5 | 6 | column "name" students 7 | column "age" students 8 | column "grade" students 9 | 10 | selectColumns [<"name"] students 11 | selectColumns [<"name", "age"] students 12 | 13 | :let renamedColumns : Table [<"name" :! String, "years" :! Nat, "favourite color" :! String] 14 | :let renamedColumns = renameColumns [<"age" ~> "years", "favorite color" ~> "favourite color"] students 15 | renamedColumns 16 | 17 | :let studentsWithFinal : Table [<"name" :! String, "age" :! Nat, "favorite color" :! String, "final" :! Nat] 18 | :let studentsWithFinal = addColumn "final" [<87, 85, 77] students 19 | studentsWithFinal 20 | 21 | column "name" studentsWithFinal 22 | column "age" studentsWithFinal 23 | column "final" studentsWithFinal 24 | 25 | :let studentsReplaceGrade : Table [<"name" :! String, "age" :! Nat, "favorite color" :! String, "grade" :! String] 26 | :let studentsReplaceGrade = replaceColumn "final" "grade" grade studentsWithFinal 27 | studentsReplaceGrade 28 | 29 | :let studentsCastAge : Table [<"name" :! String, "age" :! Int, "favorite color" :! String] 30 | :let studentsCastAge = updateColumn "age" cast students 31 | studentsCastAge 32 | 33 | :let studentsWithGrade : Table [<"name" :! String, "age" :! Nat, "favorite color" :! String, "final" :! Nat, "grade" :! String] 34 | :let studentsWithGrade = buildColumn "grade" (\[<_, _, _, final] => grade final) studentsWithFinal 35 | studentsWithGrade 36 | 37 | dropColumn "age" students 38 | dropColumn "favorite color" students 39 | dropColumn "grade" students 40 | 41 | dropColumns [<"age"] students 42 | dropColumns [<"age", "favorite color"] students 43 | 44 | allColumns (drop StudentSchema "age") 45 | allColumns StudentSchema 46 | EOF 47 | -------------------------------------------------------------------------------- /tests/Frame/ExampleTables.idr: -------------------------------------------------------------------------------- 1 | import Data.Table 2 | 3 | 0 4 | EmployeeSchema : Schema 5 | EmployeeSchema = [<"Last Name" :! String, "Department ID" :! Maybe Nat] 6 | 7 | 0 8 | DepartmentSchema : Schema 9 | DepartmentSchema = [<"Department ID" :! Nat, "Department Name" :! String, "Manager" :! String] 10 | 11 | employees : Frame EmployeeSchema 3 12 | employees = [< 13 | [<"Rafferty", Just 31], 14 | [<"Jones", Just 32], 15 | [<"Heisenberg", Just 33] 16 | ] 17 | 18 | robinson : Record EmployeeSchema 19 | robinson = [<"Robinson", Just 34] 20 | 21 | smith : Record EmployeeSchema 22 | smith = [<"Smith", Just 34] 23 | 24 | williams : Record EmployeeSchema 25 | williams = [<"Williams", Nothing] 26 | 27 | moreEmployees : Frame EmployeeSchema 3 28 | moreEmployees = [ Fin n -> Record schema 40 | rowFromEnd frm k = rowFromEnd (table frm) k 41 | -------------------------------------------------------------------------------- /tests/Frame/expected: -------------------------------------------------------------------------------- 1 | Element [<[<"Rafferty", Just 31], 2 | [<"Jones", Just 32], 3 | [<"Heisenberg", Just 33]] (SnocTable (SnocTable (SnocTable EmptyTable))) 4 | Element [<[<"Robinson", Just 34], 5 | [<"Smith", Just 34], 6 | [<"Williams", Nothing]] (SnocTable (SnocTable (SnocTable EmptyTable))) 7 | 8 | Element [<] EmptyTable 9 | Element [<[<"Rafferty", Just 31], 10 | [<"Jones", Just 32], 11 | [<"Heisenberg", Just 33], 12 | [<"Robinson", Just 34]] (SnocTable (SnocTable (SnocTable (SnocTable EmptyTable)))) 13 | 14 | Element [<[<"Rafferty", Just 31], [<"Jones", Just 32]] (SnocTable (SnocTable EmptyTable)) 15 | [<"Heisenberg", Just 33] 16 | 17 | Element [<[<"Robinson", Just 34], 18 | [<"Smith", Just 34], 19 | [<"Williams", Nothing]] (SnocTable (SnocTable (SnocTable EmptyTable))) 20 | [<[<"Rafferty", Just 31], [<"Jones", Just 32], [<"Heisenberg", Just 33]] 21 | 22 | Element [<[<"Rafferty", Just 31, 31, "Sales", "Harriet"], 23 | [<"Jones", Just 32, 32, "Finance", "George"], 24 | [<"Heisenberg", 25 | Just 33, 26 | 33, 27 | "Production", 28 | "Charles"]] (SnocTable (SnocTable (SnocTable EmptyTable))) 29 | Error: When unifying: 30 | Subset (Table DepartmentSchema) (\arg => HasRows arg 0) 31 | and: 32 | Subset (Table DepartmentSchema) (\arg => HasRows arg 1) 33 | Mismatch between: 0 and 1. 34 | 35 | (Interactive):1:27--1:29 36 | 1 | Frame.(|+|) employees [/dev/null || echo 1) 5 | 6 | TEST_SCRIPTS := $(wildcard */run) $(wildcard */*/run) 7 | DEPENDS := $(TEST_SCRIPTS:run=depends) 8 | 9 | test: build/exec/table-tests $(DEPENDS) 10 | ./build/exec/table-tests idris2 $(INTERACTIVE) --timing --failure-file failures --threads $(threads) --only $(only) 11 | 12 | retest: build/exec/table-tests $(DEPENDS) 13 | ./build/exec/table-tests idris2 $(INTERACTIVE) --timing --failure-file failures --threads $(threads) --only-file failures --only $(only) 14 | 15 | build/exec/table-tests: table-tests.ipkg TableTests.idr 16 | idris2 --build table-tests.ipkg 17 | 18 | %/depends: 19 | @mkdir "$@" 20 | @ln -s "$(CURDIR)/../build/ttc" "$@/table-0" 21 | @ln -s "$(CURDIR)/../B2T2/build/ttc" "$@/b2t2-0" 22 | 23 | clean: 24 | $(RM) failures 25 | $(RM) -r build 26 | @find . -depth -name 'depends' -type d -exec rm -rf {} \; 27 | @find . -type f -name 'output' -exec rm -rf {} \; 28 | -------------------------------------------------------------------------------- /tests/Record/ExampleRecord.idr: -------------------------------------------------------------------------------- 1 | import Data.Table 2 | 3 | StudentSchema : Schema 4 | StudentSchema = [<"name" :! String, "age" :! Nat, "favorite color" :! String] 5 | 6 | ResultsSchema : Schema 7 | ResultsSchema = [<"quiz1" :! Nat, "quiz2" :! Nat] 8 | 9 | exampleRecord : Record StudentSchema 10 | exampleRecord = [<"Bob", 12, "blue"] 11 | 12 | anotherRecord : Record StudentSchema 13 | anotherRecord = [<"Alice", 17, "green"] 14 | 15 | ambiguousRecord : Record [<"x" :! Nat, "x" :! String] 16 | ambiguousRecord = [<0, "Hello, world"] 17 | -------------------------------------------------------------------------------- /tests/Record/expected: -------------------------------------------------------------------------------- 1 | [<"Bob", 12, "blue"] 2 | 3 | "Bob" 4 | 12 5 | Error: Can't find an implementation for Field StudentSchema "grade" ?type. 6 | 7 | (Interactive):1:11--1:18 8 | 1 | value "grade" exampleRecord 9 | ^^^^^^^ 10 | 11 | Error: Multiple solutions found in search of: 12 | Field [<("x" :! Nat), ("x" :! String)] "x" ?type 13 | 14 | (Interactive):1:11--1:14 15 | 1 | value "x" ambiguousRecord 16 | ^^^ 17 | 18 | Possible correct results: 19 | Here 20 | There Here 21 | 0 22 | "Hello, world" 23 | 24 | "Bob" 25 | 12 26 | Error: Can't find an implementation 27 | for HasIndex StudentSchema (There (There (There (There ?sa)))) 3. 28 | 29 | (Interactive):1:11--1:12 30 | 1 | value 3 exampleRecord 31 | ^ 32 | 33 | 34 | [<"Bob", 13, "blue"] 35 | Error: Can't find an implementation for Field StudentSchema "age" String. 36 | 37 | (Interactive):1:14--1:19 38 | 1 | setValue "age" (the String "teen") exampleRecord 39 | ^^^^^ 40 | 41 | 42 | [<"Bob", "blue"] 43 | [<"Bob", 12] 44 | 45 | [<"Bob", 12, "blue"] 46 | [<"Alice", 17, "green"] 47 | 48 | [<"Bob", 12, "blue"] 49 | 50 | [<"Bob", False, "blue"] 51 | 52 | [<"Bob", 13, "blue"] 53 | 54 | [<"Bob", 12, "blue"] 55 | 56 | [<"Bob", 13, Nothing] 57 | 58 | [<"Bob", "blue"] 59 | [<"Bob", 12] 60 | Error: Can't find an implementation for Field StudentSchema "grade" ?type. 61 | 62 | (Interactive):1:15--1:22 63 | 1 | dropField "grade" exampleRecord 64 | ^^^^^^^ 65 | 66 | 67 | [<"Bob"] 68 | [<"Bob"] 69 | 70 | [<"Bob", 12, "blue", 8, 9] 71 | 72 | True 73 | False 74 | 75 | LT 76 | EQ 77 | GT 78 | 79 | GT 80 | EQ 81 | LT 82 | 83 | -------------------------------------------------------------------------------- /tests/Record/run: -------------------------------------------------------------------------------- 1 | . ../testutils.sh 2 | 3 | basicTest ExampleRecord.idr << EOF 4 | exampleRecord 5 | 6 | value "name" exampleRecord 7 | value "age" exampleRecord 8 | value "grade" exampleRecord 9 | value "x" ambiguousRecord 10 | the Nat $ value "x" ambiguousRecord 11 | the String $ value "x" ambiguousRecord 12 | 13 | value 0 exampleRecord 14 | value 1 exampleRecord 15 | value 3 exampleRecord 16 | 17 | setValue "age" 13 exampleRecord 18 | setValue "age" (the String "teen") exampleRecord 19 | 20 | selectFields [<"name", "favorite color"] exampleRecord 21 | selectFields [<0, 1] exampleRecord 22 | 23 | :let concatRecord = exampleRecord ++ anotherRecord 24 | selectLeft {schema1 = StudentSchema} {schema2 = StudentSchema} concatRecord 25 | selectRight {schema1 = StudentSchema} {schema2 = StudentSchema} concatRecord 26 | 27 | :let exampleRenamed : Record [<"name" :! String, "years" :! Nat, "favourite color" :! String] 28 | :let exampleRenamed = renameFields [<"age" ~> "years", "favorite color" ~> "favourite color"] exampleRecord 29 | exampleRenamed 30 | 31 | :let exampleReplaceAge : Record [<"name" :! String, "isTeen" :! Bool, "favorite color" :! String] 32 | :let exampleReplaceAge = replaceField "age" "isTeen" False exampleRecord 33 | exampleReplaceAge 34 | 35 | -- Note modified "age" type 36 | :let exampleSetAge : Record [<"name" :! String, "age" :! Int, "favorite color" :! String] 37 | :let exampleSetAge = setField "age" 13 exampleRecord 38 | exampleSetAge 39 | 40 | :let exampleCastAge : Record [<"name" :! String, "age" :! Int, "favorite color" :! String] 41 | :let exampleCastAge = updateField "age" cast exampleRecord 42 | exampleCastAge 43 | 44 | :let exampleUpdateFields : Record [<"name" :! String, "age" :! Int, "favorite color" :! Maybe String] 45 | :let exampleUpdateFields = updateFields [<"age" ::= 13, "favorite color" ::= Nothing] exampleRecord 46 | exampleUpdateFields 47 | 48 | dropField "age" exampleRecord 49 | dropField "favorite color" exampleRecord 50 | dropField "grade" exampleRecord 51 | 52 | dropFields [<"age", "favorite color"] exampleRecord 53 | dropFields [<1, 2] exampleRecord 54 | 55 | the (Record $ StudentSchema ++ ResultsSchema) $ exampleRecord ++ [<8, 9] 56 | 57 | exampleRecord == [<"Bob", 12, "blue"] 58 | exampleRecord == anotherRecord 59 | 60 | compare anotherRecord exampleRecord 61 | compare exampleRecord [<"Bob", 12, "blue"] 62 | compare exampleRecord anotherRecord 63 | 64 | compare @{byField "age"} anotherRecord exampleRecord 65 | compare @{byField "age"} exampleRecord [<"Bob", 12, "blue"] 66 | compare @{byField "age"} exampleRecord anotherRecord 67 | EOF 68 | -------------------------------------------------------------------------------- /tests/Row/ExampleTables.idr: -------------------------------------------------------------------------------- 1 | import Data.Table 2 | 3 | 0 4 | EmployeeSchema : Schema 5 | EmployeeSchema = [<"Last Name" :! String, "Department ID" :! Maybe Nat] 6 | 7 | 0 8 | DepartmentSchema : Schema 9 | DepartmentSchema = [<"Department ID" :! Nat, "Department Name" :! String, "Manager" :! String] 10 | 11 | employees : Table EmployeeSchema 12 | employees = [< 13 | [<"Rafferty", Just 31], 14 | [<"Jones", Just 32], 15 | [<"Heisenberg", Just 33] 16 | ] 17 | 18 | robinson : Record EmployeeSchema 19 | robinson = [<"Robinson", Just 34] 20 | 21 | smith : Record EmployeeSchema 22 | smith = [<"Smith", Just 34] 23 | 24 | williams : Record EmployeeSchema 25 | williams = [<"Williams", Nothing] 26 | 27 | moreEmployees : Table EmployeeSchema 28 | moreEmployees = [ Record EmployeeSchema -> Bool 40 | sameDepartment [<_, x] [<_, y] = x == y 41 | 42 | displayName : Record EmployeeSchema -> String 43 | displayName [ Bool 47 | hasDepartment [ String 51 | colorWarmth color = ifThenElse (color == "red") "warm" "cool" 52 | 53 | average : List Nat -> Double 54 | average xs = (cast $ sum xs) / (cast $ length xs) 55 | 56 | mFloor : Nat -> Nat -> Nat 57 | mFloor n k = minus k $ mod k n 58 | 59 | Cast Bool Nat where 60 | cast False = 0 61 | cast True = 1 62 | -------------------------------------------------------------------------------- /tests/Row/expected: -------------------------------------------------------------------------------- 1 | [<[<"Rafferty", Just 31], [<"Jones", Just 32], [<"Heisenberg", Just 33]] 2 | [<[<"Robinson", Just 34], [<"Smith", Just 34], [<"Williams", Nothing]] 3 | 4 | [<[<"Rafferty", Just 31], 5 | [<"Jones", Just 32], 6 | [<"Heisenberg", Just 33], 7 | [<"Robinson", Just 34], 8 | [<"Smith", Just 34], 9 | [<"Williams", Nothing]] 10 | 11 | [<[<"Robinson", Just 34], [<"Smith", Just 34], [<"Williams", Nothing]] 12 | [<[<"Robinson", Just 34], [<"Smith", Just 34], [<"Williams", Nothing]] 13 | [<[<"Robinson", Just 34]] 14 | 15 | [<[<"Rafferty", Just 31], 16 | [<"Jones", Just 32], 17 | [<"Heisenberg", Just 33], 18 | [<"Robinson", Just 34], 19 | [<"Smith", Just 34], 20 | [<"Williams", Nothing]] 21 | [<[<"Rafferty", Just 31], 22 | [<"Jones", Just 32], 23 | [<"Heisenberg", Just 33], 24 | [<"Robinson", Just 34], 25 | [<"Smith", Just 34], 26 | [<"Williams", Nothing]] 27 | [<[<"Rafferty", Just 31], [<"Jones", Just 32], [<"Heisenberg", Just 33], [<"Robinson", Just 34]] 28 | 29 | [<[<"Rafferty", Just 31, 31, "Sales", "Harriet"], 30 | [<"Jones", Just 32, 32, "Finance", "George"], 31 | [<"Heisenberg", Just 33, 33, "Production", "Charles"]] 32 | Error: Can't find an implementation for HasRows [ \case "" => displayName rec; x => "\{displayName rec}, \{x}") (the String "") allEmployees 36 | 37 | distinctBy sameDepartment $ allEmployees ++ allEmployees 38 | distinct $ allEmployees ++ allEmployees 39 | 40 | mapFst finToNat <$> enum allEmployees 41 | 42 | finToNat <$> findIndexBy ((== Just 32) . value "Department ID") allEmployees 43 | finToNat <$> findIndexBy ((== Just 35) . value "Department ID") allEmployees 44 | 45 | finToNat <$> findIndex robinson allEmployees 46 | finToNat <$> findIndex robinson employees 47 | 48 | sort allEmployees 49 | sort @{byField "Department ID"} allEmployees 50 | 51 | filter hasDepartment allEmployees 52 | dropNa "Department ID" allEmployees 53 | 54 | row employees 0 55 | row employees 1 56 | row employees 2 57 | row employees 3 58 | 59 | dropRows employees 0 60 | dropRows employees 1 61 | dropRows employees 2 62 | dropRows employees 3 63 | dropRows employees 4 64 | 65 | init employees 0 66 | init employees 1 67 | init employees 2 68 | init employees 3 69 | init employees 4 70 | EOF 71 | 72 | b2t2Test ExampleTables.idr << 'EOF' 73 | SortedMap.toList $ map average $ groupBy (colorWarmth . value "favorite color") (length . value "name") students 74 | 75 | SortedMap.toList $ groupBy (mFloor 5 . value "age") (value "name") students 76 | SortedMap.toList $ groupBy (mFloor 5 . value "final") (value "name") gradebook 77 | SortedMap.toList $ group "favorite color" students 78 | SortedMap.toList $ group "age" gradebook 79 | SortedMap.toList $ groupMany [<"red", "black"] jellyNamed 80 | SortedMap.toList $ groupKeepKey "favorite color" students 81 | SortedMap.toList $ groupKeepKey "age" gradebook 82 | SortedMap.toList $ groupManyKeepKeys [<"red", "black"] jellyNamed 83 | 84 | SortedMap.toList $ countBy (mFloor 5 . value "age") students 85 | SortedMap.toList $ countBy (mFloor 5 . value "final") gradebook 86 | SortedMap.toList $ count "favorite color" students 87 | SortedMap.toList $ count "age" gradebook 88 | 89 | :let studentsPivot : Table [<"favorite color" :! String, "age-average" :! Double] 90 | :let studentsPivot = pivot [<"favorite color"] [<"age" ~> "age-average" $$= average] students 91 | studentsPivot 92 | 93 | :let jellyPivot : Table [<"get acne" :! Bool, "brown" :! Bool, "red proportion" :! Double, "pink proportion" :! Double] 94 | :let jellyPivot = pivot [<"get acne", "brown"] [<"red" ~> "red proportion" $$= average . map cast, "pink" ~> "pink proportion" $$= average . map cast] jellyNamed 95 | jellyPivot 96 | 97 | melt [<"midterm", "final"] "exam" "score" gradebook 98 | 99 | :let longerGradebook : Table [<"name" :! String, "age" :! Nat, "test" :! String, "score" :! Nat] 100 | :let longerGradebook = melt [<"quiz1", "quiz2", "midterm", "quiz3", "quiz4", "final"] "test" "score" gradebook 101 | longerGradebook 102 | 103 | unmelt students "name" "age" 104 | unmelt longerGradebook "test" "score" 105 | 106 | the (Table [<"name" :! String, "age" :! Nat, "quizzes" :! Nat, "midterm" :! Nat, "final" :! Nat]) $ flatten [<"quizzes"] gradebookSeq 107 | the (Table [<"name" :! String, "age" :! Nat, "quizzes" :! Nat, "midterm" :! Nat, "final" :! Nat, "quiz-pass?" :! Bool]) $ flatten [<"quizzes", "quiz-pass?"] $ buildColumn "quiz-pass?" (map (>= 8) . value "quizzes") gradebookSeq 108 | EOF 109 | -------------------------------------------------------------------------------- /tests/Schema/ExampleSchema.idr: -------------------------------------------------------------------------------- 1 | import Data.Table 2 | 3 | exampleSchema : Schema 4 | exampleSchema = [<"name" :! String, "age" :! Nat, "favorite color" :! String] 5 | 6 | additionalColumns : Schema 7 | additionalColumns = [<"quiz1" :! Nat, "quiz2" :! Nat] 8 | 9 | ambiguousSchema : Schema 10 | ambiguousSchema = [<"x" :! Nat, "x" :! String] 11 | -------------------------------------------------------------------------------- /tests/Schema/expected: -------------------------------------------------------------------------------- 1 | [<("name" :! String), ("age" :! Nat), ("favorite color" :! String)] 2 | 3 | [<"name", "age", "favorite color"] 4 | [ "years", "favorite color" ~> "favourite color"] 17 | 18 | update exampleSchema "age" Int 19 | update exampleSchema [<"age" :! Int, "favorite color" :! Maybe String] 20 | 21 | complement exampleSchema [<"age"] 22 | complement exampleSchema [<"name", "favorite color"] 23 | complement exampleSchema [<1] 24 | complement exampleSchema [<0, 2] 25 | complement exampleSchema [<"age", 2] 26 | 27 | drop exampleSchema "age" 28 | drop exampleSchema "favorite color" 29 | drop exampleSchema "grade" 30 | drop ambiguousSchema "x" 31 | drop ambiguousSchema {type = Nat} "x" 32 | drop ambiguousSchema {type = String} "x" 33 | 34 | drop exampleSchema 1 35 | drop exampleSchema 2 36 | drop exampleSchema 3 37 | drop ambiguousSchema 1 38 | EOF 39 | -------------------------------------------------------------------------------- /tests/Show/ExampleTables.idr: -------------------------------------------------------------------------------- 1 | import Data.Table 2 | 3 | exampleTable : Table [< 4 | "name" :! String, 5 | "age" :! Nat, 6 | "quizzes" :! Table [<"quiz#" :! Nat, "grade" :! Nat], 7 | "midterm" :! Nat, 8 | "final" :! Nat 9 | ] 10 | exampleTable = [< 11 | [<"Bob", 12, [<[<1, 8], 12 | [<2, 9], 13 | [<3, 7], 14 | [<4, 9]], 77, 87], 15 | 16 | [<"Alice", 17, [<[<1, 6], 17 | [<2, 8], 18 | [<3, 8], 19 | [<4, 7]], 88, 85], 20 | 21 | [<"Eve", 13, [<[<1, 7], 22 | [<2, 9], 23 | [<3, 8], 24 | [<4, 8]], 84, 77] 25 | ] 26 | 27 | exampleFrame : Frame [< 28 | "name" :! String, 29 | "age" :! Nat, 30 | "quizzes" :! Table [<"quiz#" :! Nat, "grade" :! Nat], 31 | "midterm" :! Nat, 32 | "final" :! Nat 33 | ] 3 34 | exampleFrame = [< 35 | [<"Bob", 12, [<[<1, 8], 36 | [<2, 9], 37 | [<3, 7], 38 | [<4, 9]], 77, 87], 39 | 40 | [<"Alice", 17, [<[<1, 6], 41 | [<2, 8], 42 | [<3, 8], 43 | [<4, 7]], 88, 85], 44 | 45 | [<"Eve", 13, [<[<1, 7], 46 | [<2, 9], 47 | [<3, 8], 48 | [<4, 8]], 84, 77] 49 | ] 50 | -------------------------------------------------------------------------------- /tests/Show/expected: -------------------------------------------------------------------------------- 1 | 2 | | name | age | quizzes | midterm | final | 3 | | ------- | --- | ----------------- | ------- | ----- | 4 | | "Bob" | 12 | | 77 | 87 | 5 | | | | | quiz# | grade | | | | 6 | | | | | ----- | ----- | | | | 7 | | | | | 1 | 8 | | | | 8 | | | | | 2 | 9 | | | | 9 | | | | | 3 | 7 | | | | 10 | | | | | 4 | 9 | | | | 11 | | "Alice" | 17 | | 88 | 85 | 12 | | | | | quiz# | grade | | | | 13 | | | | | ----- | ----- | | | | 14 | | | | | 1 | 6 | | | | 15 | | | | | 2 | 8 | | | | 16 | | | | | 3 | 8 | | | | 17 | | | | | 4 | 7 | | | | 18 | | "Eve" | 13 | | 84 | 77 | 19 | | | | | quiz# | grade | | | | 20 | | | | | ----- | ----- | | | | 21 | | | | | 1 | 7 | | | | 22 | | | | | 2 | 9 | | | | 23 | | | | | 3 | 8 | | | | 24 | | | | | 4 | 8 | | | | 25 | 26 | Element 27 | | name | age | quizzes | midterm | final | 28 | | ------- | --- | ----------------- | ------- | ----- | 29 | | "Bob" | 12 | | 77 | 87 | 30 | | | | | quiz# | grade | | | | 31 | | | | | ----- | ----- | | | | 32 | | | | | 1 | 8 | | | | 33 | | | | | 2 | 9 | | | | 34 | | | | | 3 | 7 | | | | 35 | | | | | 4 | 9 | | | | 36 | | "Alice" | 17 | | 88 | 85 | 37 | | | | | quiz# | grade | | | | 38 | | | | | ----- | ----- | | | | 39 | | | | | 1 | 6 | | | | 40 | | | | | 2 | 8 | | | | 41 | | | | | 3 | 8 | | | | 42 | | | | | 4 | 7 | | | | 43 | | "Eve" | 13 | | 84 | 77 | 44 | | | | | quiz# | grade | | | | 45 | | | | | ----- | ----- | | | | 46 | | | | | 1 | 7 | | | | 47 | | | | | 2 | 9 | | | | 48 | | | | | 3 | 8 | | | | 49 | | | | | 4 | 8 | | | | 50 | _ 51 | 52 | 53 | | name | age | quizzes | midterm | final | 54 | | ------- | --- | ----------------- | ------- | ----- | 55 | | "Bob" | 12 | | 77 | 87 | 56 | | | | | quiz# | grade | | | | 57 | | | | | ----- | ----- | | | | 58 | | | | | 1 | 8 | | | | 59 | | | | | 2 | 9 | | | | 60 | | | | | 3 | 7 | | | | 61 | | | | | 4 | 9 | | | | 62 | | "Alice" | 17 | | 88 | 85 | 63 | | | | | quiz# | grade | | | | 64 | | | | | ----- | ----- | | | | 65 | | | | | 1 | 6 | | | | 66 | | | | | 2 | 8 | | | | 67 | | | | | 3 | 8 | | | | 68 | | | | | 4 | 7 | | | | 69 | | "Eve" | 13 | | 84 | 77 | 70 | | | | | quiz# | grade | | | | 71 | | | | | ----- | ----- | | | | 72 | | | | | 1 | 7 | | | | 73 | | | | | 2 | 9 | | | | 74 | | | | | 3 | 8 | | | | 75 | | | | | 4 | 8 | | | | 76 | 77 | 78 | | name | age | quizzes | midterm | final | 79 | | ------- | --- | ----------------- | ------- | ----- | 80 | | "Bob" | 12 | | 77 | 87 | 81 | | | | | quiz# | grade | | | | 82 | | | | | ----- | ----- | | | | 83 | | | | | 1 | 8 | | | | 84 | | | | | 2 | 9 | | | | 85 | | | | | 3 | 7 | | | | 86 | | | | | 4 | 9 | | | | 87 | | "Alice" | 17 | | 88 | 85 | 88 | | | | | quiz# | grade | | | | 89 | | | | | ----- | ----- | | | | 90 | | | | | 1 | 6 | | | | 91 | | | | | 2 | 8 | | | | 92 | | | | | 3 | 8 | | | | 93 | | | | | 4 | 7 | | | | 94 | | "Eve" | 13 | | 84 | 77 | 95 | | | | | quiz# | grade | | | | 96 | | | | | ----- | ----- | | | | 97 | | | | | 1 | 7 | | | | 98 | | | | | 2 | 9 | | | | 99 | | | | | 3 | 8 | | | | 100 | | | | | 4 | 8 | | | | 101 | 102 | 103 | 104 | | name | age | quizzes | midterm | final | 105 | | ------- | --- | ----------------- | ------- | ----- | 106 | | | 12 | | | | 107 | | | | | quiz# | grade | | | | 108 | | | | | ----- | ----- | | | | 109 | | "Bob" | | | 1 | 8 | | 77 | | 110 | | | | | 2 | 9 | | | | 111 | | | | | 3 | 7 | | | | 112 | | | | | 4 | 9 | | | 87 | 113 | | | 17 | | | | 114 | | | | | quiz# | grade | | | | 115 | | | | | ----- | ----- | | | | 116 | | "Alice" | | | 1 | 6 | | 88 | | 117 | | | | | 2 | 8 | | | | 118 | | | | | 3 | 8 | | | | 119 | | | | | 4 | 7 | | | 85 | 120 | | | 13 | | | | 121 | | | | | quiz# | grade | | | | 122 | | | | | ----- | ----- | | | | 123 | | "Eve" | | | 1 | 7 | | 84 | | 124 | | | | | 2 | 9 | | | | 125 | | | | | 3 | 8 | | | | 126 | | | | | 4 | 8 | | | 77 | 127 | 128 | 129 | | name | age | quizzes | midterm | final | 130 | | ------- | --- | ----------------- | ------- | ----- | 131 | | | 12 | | | | 132 | | | | | quiz# | grade | | | | 133 | | | | | ----- | ----- | | | | 134 | | "Bob" | | | 1 | 8 | | 77 | | 135 | | | | | 2 | 9 | | | | 136 | | | | | 3 | 7 | | | | 137 | | | | | 4 | 9 | | | 87 | 138 | | | 17 | | | | 139 | | | | | quiz# | grade | | | | 140 | | | | | ----- | ----- | | | | 141 | | "Alice" | | | 1 | 6 | | 88 | | 142 | | | | | 2 | 8 | | | | 143 | | | | | 3 | 8 | | | | 144 | | | | | 4 | 7 | | | 85 | 145 | | | 13 | | | | 146 | | | | | quiz# | grade | | | | 147 | | | | | ----- | ----- | | | | 148 | | "Eve" | | | 1 | 7 | | 84 | | 149 | | | | | 2 | 9 | | | | 150 | | | | | 3 | 8 | | | | 151 | | | | | 4 | 8 | | | 77 | 152 | 153 | 154 | 155 | | ------- | -- | ----------------- | -- | -- | 156 | | "Bob" | 12 | | 77 | 87 | 157 | | | | | quiz# | grade | | | | 158 | | | | | ----- | ----- | | | | 159 | | | | | 1 | 8 | | | | 160 | | | | | 2 | 9 | | | | 161 | | | | | 3 | 7 | | | | 162 | | | | | 4 | 9 | | | | 163 | | "Alice" | 17 | | 88 | 85 | 164 | | | | | quiz# | grade | | | | 165 | | | | | ----- | ----- | | | | 166 | | | | | 1 | 6 | | | | 167 | | | | | 2 | 8 | | | | 168 | | | | | 3 | 8 | | | | 169 | | | | | 4 | 7 | | | | 170 | | "Eve" | 13 | | 84 | 77 | 171 | | | | | quiz# | grade | | | | 172 | | | | | ----- | ----- | | | | 173 | | | | | 1 | 7 | | | | 174 | | | | | 2 | 9 | | | | 175 | | | | | 3 | 8 | | | | 176 | | | | | 4 | 8 | | | | 177 | 178 | 179 | | ------- | -- | ----------------- | -- | -- | 180 | | "Bob" | 12 | | 77 | 87 | 181 | | | | | quiz# | grade | | | | 182 | | | | | ----- | ----- | | | | 183 | | | | | 1 | 8 | | | | 184 | | | | | 2 | 9 | | | | 185 | | | | | 3 | 7 | | | | 186 | | | | | 4 | 9 | | | | 187 | | "Alice" | 17 | | 88 | 85 | 188 | | | | | quiz# | grade | | | | 189 | | | | | ----- | ----- | | | | 190 | | | | | 1 | 6 | | | | 191 | | | | | 2 | 8 | | | | 192 | | | | | 3 | 8 | | | | 193 | | | | | 4 | 7 | | | | 194 | | "Eve" | 13 | | 84 | 77 | 195 | | | | | quiz# | grade | | | | 196 | | | | | ----- | ----- | | | | 197 | | | | | 1 | 7 | | | | 198 | | | | | 2 | 9 | | | | 199 | | | | | 3 | 8 | | | | 200 | | | | | 4 | 8 | | | | 201 | 202 | 203 | 204 | | ------- | -- | ----------------- | -- | -- | 205 | | | 12 | | | | 206 | | | | | quiz# | grade | | | | 207 | | | | | ----- | ----- | | | | 208 | | "Bob" | | | 1 | 8 | | 77 | | 209 | | | | | 2 | 9 | | | | 210 | | | | | 3 | 7 | | | | 211 | | | | | 4 | 9 | | | 87 | 212 | | | 17 | | | | 213 | | | | | quiz# | grade | | | | 214 | | | | | ----- | ----- | | | | 215 | | "Alice" | | | 1 | 6 | | 88 | | 216 | | | | | 2 | 8 | | | | 217 | | | | | 3 | 8 | | | | 218 | | | | | 4 | 7 | | | 85 | 219 | | | 13 | | | | 220 | | | | | quiz# | grade | | | | 221 | | | | | ----- | ----- | | | | 222 | | "Eve" | | | 1 | 7 | | 84 | | 223 | | | | | 2 | 9 | | | | 224 | | | | | 3 | 8 | | | | 225 | | | | | 4 | 8 | | | 77 | 226 | 227 | 228 | | ------- | -- | ----------------- | -- | -- | 229 | | | 12 | | | | 230 | | | | | quiz# | grade | | | | 231 | | | | | ----- | ----- | | | | 232 | | "Bob" | | | 1 | 8 | | 77 | | 233 | | | | | 2 | 9 | | | | 234 | | | | | 3 | 7 | | | | 235 | | | | | 4 | 9 | | | 87 | 236 | | | 17 | | | | 237 | | | | | quiz# | grade | | | | 238 | | | | | ----- | ----- | | | | 239 | | "Alice" | | | 1 | 6 | | 88 | | 240 | | | | | 2 | 8 | | | | 241 | | | | | 3 | 8 | | | | 242 | | | | | 4 | 7 | | | 85 | 243 | | | 13 | | | | 244 | | | | | quiz# | grade | | | | 245 | | | | | ----- | ----- | | | | 246 | | "Eve" | | | 1 | 7 | | 84 | | 247 | | | | | 2 | 9 | | | | 248 | | | | | 3 | 8 | | | | 249 | | | | | 4 | 8 | | | 77 | 250 | 251 | 252 | -------------------------------------------------------------------------------- /tests/Show/run: -------------------------------------------------------------------------------- 1 | . ../testutils.sh 2 | 3 | basicTest ExampleTables.idr << EOF 4 | :exec putStrLn $ show exampleTable 5 | :exec putStrLn $ show exampleFrame 6 | 7 | :exec putStrLn $ showTable exampleTable 8 | :exec putStrLn $ showFrame exampleFrame 9 | 10 | :exec putStrLn $ showTable {halignment = [L, R, L, C, R]} {valignment = [C, T, T, C, B]} exampleTable 11 | :exec putStrLn $ showFrame {halignment = [L, R, L, C, R]} {valignment = [C, T, T, C, B]} exampleFrame 12 | 13 | :exec putStrLn $ showTableBody exampleTable 14 | :exec putStrLn $ showFrameBody exampleFrame 15 | 16 | :exec putStrLn $ showTableBody {halignment = [L, R, L, C, R]} {valignment = [C, T, T, C, B]} exampleTable 17 | :exec putStrLn $ showFrameBody {halignment = [L, R, L, C, R]} {valignment = [C, T, T, C, B]} exampleFrame 18 | EOF 19 | -------------------------------------------------------------------------------- /tests/Table/ExampleTable.idr: -------------------------------------------------------------------------------- 1 | import Data.Table 2 | 3 | students : Table [<"name" :! String, "age" :! Nat, "favorite color" :! String] 4 | students = [< 5 | [<"Bob", 12, "blue" ], 6 | [<"Alice", 17, "green"], 7 | [<"Eve", 13, "red" ] 8 | ] 9 | -------------------------------------------------------------------------------- /tests/Table/expected: -------------------------------------------------------------------------------- 1 | [<[<"Bob", 12, "blue"], [<"Alice", 17, "green"], [<"Eve", 13, "red"]] 2 | 3 | -------------------------------------------------------------------------------- /tests/Table/run: -------------------------------------------------------------------------------- 1 | . ../testutils.sh 2 | 3 | basicTest ExampleTable.idr << EOF 4 | students 5 | EOF 6 | -------------------------------------------------------------------------------- /tests/TableTests.idr: -------------------------------------------------------------------------------- 1 | module TableTests 2 | 3 | import Test.Golden 4 | 5 | main : IO () 6 | main = runner [ 7 | !(testsInDir "B2T2" (const True) "B2T2 Tests" [] Nothing), 8 | !(testsInDir "." (const True) "Table" [] Nothing) 9 | ] 10 | -------------------------------------------------------------------------------- /tests/table-tests.ipkg: -------------------------------------------------------------------------------- 1 | package table-tests 2 | 3 | sourcedir = "." 4 | 5 | depends = contrib, test 6 | 7 | main = TableTests 8 | executable = table-tests 9 | -------------------------------------------------------------------------------- /tests/testutils.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | basicTest() { 4 | idris2 --quiet --console-width 100 --no-color -p contrib -p table "$@" | sed 's/Main> //' | sed 's/\(Main> \)\+/\n/' 5 | 6 | rm -rf build 7 | } 8 | 9 | b2t2Test() { 10 | printf "%s\n%s\n" ":module B2T2" "$(cat -)" | basicTest -p b2t2 "$@" | sed '/^Imported module B2T2$/d' 11 | } 12 | --------------------------------------------------------------------------------