├── .gitignore ├── Builtin.hs ├── Compiler.hs ├── Lexer.hs ├── Lexer.x ├── License.thih ├── Main.hs ├── Makefile ├── Optimizer.hs ├── PPrint.hs ├── Parser.hs ├── PatComp.hs ├── README.md ├── SCC.hs ├── Static.hs ├── Syntax.hs ├── Test.hs ├── Type.hs └── examples ├── Makefile ├── echo.hs ├── even_lines.hs ├── fizzbuzz.hs ├── hello.hs ├── hs2lazy-prelude.hs ├── lisp.hs ├── reverse_lines.hs └── tarai.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | -------------------------------------------------------------------------------- /Builtin.hs: -------------------------------------------------------------------------------- 1 | module Builtin where 2 | import Data.List (find) 3 | import Data.Char (ord) 4 | import Syntax 5 | 6 | churchnums = [ 7 | SLit $ LitStr "`ki", -- 0 8 | SLit $ LitStr "i", -- 1 9 | SLit $ LitStr "``s``s`kski", -- 2 10 | SLit $ LitStr "``s``s`ksk``s``s`kski", -- 3 11 | SLit $ LitStr "```sii``s``s`kski", -- 4 12 | SLit $ LitStr "``s``s`ksk```sii``s``s`kski", -- 5 13 | SLit $ LitStr "``s``s`ksk``s``s`ksk```sii``s``s`kski", -- 6 14 | SLit $ LitStr "``s``s`ksk``s``s`ksk``s``s`ksk```sii``s``s`kski", -- 7 15 | SLit $ LitStr "``s`k``s``s`kski```sii``s``s`kski", -- 8 16 | SLit $ LitStr "```s``s`kski``s``s`ksk``s``s`kski", -- 9 17 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk```sii``s``s`kski", -- 10 18 | SLit $ LitStr "````s``s`kski```s``s`ksk```sii``s``s`kski`s``s`kski", -- 11 19 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski```sii``s``s`kski", -- 12 20 | SLit $ LitStr "````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`kski", -- 13 21 | SLit $ LitStr "``s``s`ksk````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`kski", -- 14 22 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 15 23 | SLit $ LitStr "```s``siii``s``s`kski", -- 16 24 | SLit $ LitStr "``s``s`ksk```s``siii``s``s`kski", -- 17 25 | SLit $ LitStr "``s``s`ksk``s``s`ksk```s``siii``s``s`kski", -- 18 26 | SLit $ LitStr "``s``s`ksk``s``s`ksk``s``s`ksk```s``siii``s``s`kski", -- 19 27 | SLit $ LitStr "`````sii``s``s`kski`s``s`ksk```s``siii``s``s`kski", -- 20 28 | SLit $ LitStr "``s``s`ksk`````sii``s``s`kski`s``s`ksk```s``siii``s``s`kski", -- 21 29 | SLit $ LitStr "``s`k``s``s`kski````s``s`kski```s``s`ksk```sii``s``s`kski`s``s`kski", -- 22 30 | SLit $ LitStr "````s``s`kski`````s``s`kski```s``s`ksk```sii``s``s`kski`s``s`kski`s``s`kski", -- 23 31 | SLit $ LitStr "````s``s`kski````sii``s``s`kski`s``s`ksk```s``siii``s``s`kski", -- 24 32 | SLit $ LitStr "```s``s`kski``s``s`ksk```sii``s``s`kski", -- 25 33 | SLit $ LitStr "``s``s`ksk```s``s`kski``s``s`ksk```sii``s``s`kski", -- 26 34 | SLit $ LitStr "```sii``s``s`ksk``s``s`kski", -- 27 35 | SLit $ LitStr "``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 28 36 | SLit $ LitStr "``s``s`ksk``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 29 37 | SLit $ LitStr "``s``s`ksk``s``s`ksk``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 30 38 | SLit $ LitStr "`````sii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 31 39 | SLit $ LitStr "``s`k``s``s`kski```s``siii``s``s`kski", -- 32 40 | SLit $ LitStr "````s``s`kski````s``siii``s``s`kski`s``s`kski", -- 33 41 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk```s``siii``s``s`kski", -- 34 42 | SLit $ LitStr "````s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 35 43 | SLit $ LitStr "```s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`kski", -- 36 44 | SLit $ LitStr "``s``s`ksk```s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`kski", -- 37 45 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk``s``s`ksk``s``s`ksk```s``siii``s``s`kski", -- 38 46 | SLit $ LitStr "````s``s`kski```s``s`ksk``s``s`ksk``s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 39 47 | SLit $ LitStr "``s`k``s``s`kski`````sii``s``s`kski`s``s`ksk```s``siii``s``s`kski", -- 40 48 | SLit $ LitStr "`````s``siii``s``s`kski`s``s`ksk```s``s`kski``s``s`ksk```sii``s``s`kski", -- 41 49 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk`````sii``s``s`kski`s``s`ksk```s``siii``s``s`kski", -- 42 50 | SLit $ LitStr "`````s``siii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 43 51 | SLit $ LitStr "``s``s`ksk`````s``siii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 44 52 | SLit $ LitStr "``s`k``s``s`ksk```sii``s``s`kski```s``s`kski``s``s`ksk``s``s`kski", -- 45 53 | SLit $ LitStr "````s``s`ksk```sii``s``s`kski````s``s`kski``s``s`ksk``s``s`kski`s``s`kski", -- 46 54 | SLit $ LitStr "``s``s`ksk````s``s`ksk```sii``s``s`kski````s``s`kski``s``s`ksk``s``s`kski`s``s`kski", -- 47 55 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski```s``siii``s``s`kski", -- 48 56 | SLit $ LitStr "````s``s`ksk``s``s`kski````s``siii``s``s`kski`s``s`kski", -- 49 57 | SLit $ LitStr "``s`k``s``s`kski```s``s`kski``s``s`ksk```sii``s``s`kski", -- 50 58 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski``s``s`ksk```s``siii``s``s`kski", -- 51 59 | SLit $ LitStr "````s``s`ksk``s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 52 60 | SLit $ LitStr "``s``s`ksk````s``s`ksk``s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 53 61 | SLit $ LitStr "``s`k``s``s`kski```sii``s``s`ksk``s``s`kski", -- 54 62 | SLit $ LitStr "````s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski", -- 55 63 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 56 64 | SLit $ LitStr "````s``s`kski```s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 57 65 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 58 66 | SLit $ LitStr "````s``s`kski````s``siii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 59 67 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski`````sii``s``s`kski`s``s`ksk```s``siii``s``s`kski", -- 60 68 | SLit $ LitStr "````s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 61 69 | SLit $ LitStr "``s`k``s``s`kski`````sii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 62 70 | SLit $ LitStr "````s``s`kski``````sii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 63 71 | SLit $ LitStr "```s`s``s`ksk``sii``s``s`kski", -- 64 72 | SLit $ LitStr "``s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 65 73 | SLit $ LitStr "``s``s`ksk``s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 66 74 | SLit $ LitStr "``s``s`ksk``s``s`ksk``s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 67 75 | SLit $ LitStr "``s`k```sii``s``s`kski``s``s`ksk```s``siii``s``s`kski", -- 68 76 | SLit $ LitStr "`````sii``s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 69 77 | SLit $ LitStr "``s``s`ksk`````sii``s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 70 78 | SLit $ LitStr "``s``s`ksk``s``s`ksk`````sii``s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 71 79 | SLit $ LitStr "``s`k```sii``s``s`kski``s``s`ksk``s``s`ksk```s``siii``s``s`kski", -- 72 80 | SLit $ LitStr "`````sii``s``s`kski```s``s`ksk``s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 73 81 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk```s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`kski", -- 74 82 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski```s``s`kski``s``s`ksk```sii``s``s`kski", -- 75 83 | SLit $ LitStr "````s``s`ksk``s``s`kski````s``s`kski``s``s`ksk```sii``s``s`kski`s``s`kski", -- 76 84 | SLit $ LitStr "``s``s`ksk````s``s`ksk``s``s`kski````s``s`kski``s``s`ksk```sii``s``s`kski`s``s`kski", -- 77 85 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski``s``s`ksk```s``s`kski``s``s`ksk```sii``s``s`kski", -- 78 86 | SLit $ LitStr "````s``s`ksk``s``s`kski```s``s`ksk```s``s`kski``s``s`ksk```sii``s``s`kski`s``s`kski", -- 79 87 | SLit $ LitStr "``s`k``s``s`ksk```sii``s``s`kski```s``siii``s``s`kski", -- 80 88 | SLit $ LitStr "```s``sii`s``s`ksk``s``s`kski", -- 81 89 | SLit $ LitStr "``s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 82 90 | SLit $ LitStr "``s``s`ksk``s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 83 91 | SLit $ LitStr "``s``s`ksk``s``s`ksk``s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 84 92 | SLit $ LitStr "`````sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 85 93 | SLit $ LitStr "``s``s`ksk`````sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 86 94 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 87 95 | SLit $ LitStr "````s``s`ksk``s``s`kski```s``s`ksk``s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 88 96 | SLit $ LitStr "````s``s`kski````sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 89 97 | SLit $ LitStr "`````s``s`kski``s``s`ksk``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 90 98 | SLit $ LitStr "`````sii``s``s`ksk``s``s`kski`s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 91 99 | SLit $ LitStr "``s``s`ksk`````sii``s``s`ksk``s``s`kski`s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 92 100 | SLit $ LitStr "````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 93 101 | SLit $ LitStr "``s``s`ksk````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 94 102 | SLit $ LitStr "``s`k``s``s`ksk```sii``s``s`kski``s``s`ksk``s``s`ksk``s``s`ksk```s``siii``s``s`kski", -- 95 103 | SLit $ LitStr "``s`k``s``s`ksk``s``s`ksk```sii``s``s`kski```s``siii``s``s`kski", -- 96 104 | SLit $ LitStr "`````s``siii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 97 105 | SLit $ LitStr "``s`k``s``s`kski````s``s`ksk``s``s`kski````s``siii``s``s`kski`s``s`kski", -- 98 106 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski````s``s`kski````s``siii``s``s`kski`s``s`kski", -- 99 107 | SLit $ LitStr "```s``s`kski``s`k``s``s`kski``s``s`ksk```sii``s``s`kski", -- 100 108 | SLit $ LitStr "``s``s`ksk```s``s`kski``s`k``s``s`kski``s``s`ksk```sii``s``s`kski", -- 101 109 | SLit $ LitStr "``s`k``s``s`ksk``s``s`ksk```sii``s``s`kski``s``s`ksk```s``siii``s``s`kski", -- 102 110 | SLit $ LitStr "````s``s`ksk``s``s`ksk```sii``s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 103 111 | SLit $ LitStr "``s`k```sii``s``s`kski``s``s`ksk```s``s`kski``s``s`ksk```sii``s``s`kski", -- 104 112 | SLit $ LitStr "`````sii``s``s`kski```s``s`ksk```s``s`kski``s``s`ksk```sii``s``s`kski`s``s`kski", -- 105 113 | SLit $ LitStr "`````s``s`kski``s``s`ksk```sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 106 114 | SLit $ LitStr "````s``s`ksk```sii``s``s`kski````s``siii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 107 115 | SLit $ LitStr "``s`k```sii``s``s`kski```sii``s``s`ksk``s``s`kski", -- 108 116 | SLit $ LitStr "`````sii``s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski", -- 109 117 | SLit $ LitStr "``s``s`ksk`````sii``s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski", -- 110 118 | SLit $ LitStr "``s``s`ksk``s``s`ksk`````sii``s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski", -- 111 119 | SLit $ LitStr "``s`k```sii``s``s`kski``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 112 120 | SLit $ LitStr "`````sii``s``s`kski```s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 113 121 | SLit $ LitStr "``s``s`ksk`````sii``s``s`kski```s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 114 122 | SLit $ LitStr "````s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 115 123 | SLit $ LitStr "``s`k```sii``s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 116 124 | SLit $ LitStr "`````sii``s``s`kski```s``s`ksk``s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 117 125 | SLit $ LitStr "````s``s`kski````sii``s``s`ksk``s``s`kski`s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 118 126 | SLit $ LitStr "``s`k``s``s`ksk``s``s`ksk``s``s`ksk```sii``s``s`kski``s``s`ksk```s``siii``s``s`kski", -- 119 127 | SLit $ LitStr "``s`k```sii``s``s`kski``s``s`ksk``s``s`ksk``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 120 128 | SLit $ LitStr "```s``s`kski````s``s`kski```s``s`ksk```sii``s``s`kski`s``s`kski", -- 121 129 | SLit $ LitStr "``s``s`ksk```s``s`kski````s``s`kski```s``s`ksk```sii``s``s`kski`s``s`kski", -- 122 130 | SLit $ LitStr "``s``s`ksk``s``s`ksk```s``s`kski````s``s`kski```s``s`ksk```sii``s``s`kski`s``s`kski", -- 123 131 | SLit $ LitStr "`````sii``s``s`kski````sii``s``s`ksk``s``s`kski`s``s`ksk```s``siii``s``s`kski", -- 124 132 | SLit $ LitStr "```s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 125 133 | SLit $ LitStr "``s``s`ksk```s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 126 134 | SLit $ LitStr "``s``s`ksk``s``s`ksk```s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 127 135 | SLit $ LitStr "``s`k``s``s`kski```s`s``s`ksk``sii``s``s`kski", -- 128 136 | SLit $ LitStr "````s``s`kski````s`s``s`ksk``sii``s``s`kski`s``s`kski", -- 129 137 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 130 138 | SLit $ LitStr "````s``s`kski```s``s`ksk```s`s``s`ksk``sii``s``s`kski`s``s`kski", -- 131 139 | SLit $ LitStr "``s`k```sii``s``s`kski````s``s`kski````s``siii``s``s`kski`s``s`kski", -- 132 140 | SLit $ LitStr "`````sii``s``s`kski`````s``s`kski````s``siii``s``s`kski`s``s`kski`s``s`kski", -- 133 141 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk``s``s`ksk``s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 134 142 | SLit $ LitStr "``s`k``s``s`ksk```sii``s``s`kski```sii``s``s`ksk``s``s`kski", -- 135 143 | SLit $ LitStr "````s``s`ksk```sii``s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski", -- 136 144 | SLit $ LitStr "``s``s`ksk````s``s`ksk```sii``s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski", -- 137 145 | SLit $ LitStr "``s`k``s``s`kski`````sii``s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 138 146 | SLit $ LitStr "````s``s`ksk```sii``s``s`kski````sii``s``s`ksk``s``s`kski`s``s`ksk```sii``s``s`kski", -- 139 147 | SLit $ LitStr "``s`k``s``s`ksk```sii``s``s`kski``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 140 148 | SLit $ LitStr "````s``s`ksk```sii``s``s`kski```s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 141 149 | SLit $ LitStr "``s``s`ksk````s``s`ksk```sii``s``s`kski```s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 142 150 | SLit $ LitStr "``s``s`ksk``s``s`ksk````s``s`ksk```sii``s``s`kski```s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 143 151 | SLit $ LitStr "```s``s`kski``s`k``s``s`ksk``s``s`kski```sii``s``s`kski", -- 144 152 | SLit $ LitStr "``s``s`ksk```s``s`kski``s`k``s``s`ksk``s``s`kski```sii``s``s`kski", -- 145 153 | SLit $ LitStr "``s``s`ksk``s``s`ksk```s``s`kski``s`k``s``s`ksk``s``s`kski```sii``s``s`kski", -- 146 154 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski````s``s`ksk``s``s`kski````s``siii``s``s`kski`s``s`kski", -- 147 155 | SLit $ LitStr "``s`k```sii``s``s`kski``s``s`ksk```s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`kski", -- 148 156 | SLit $ LitStr "`````sii``s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 149 157 | SLit $ LitStr "``s`k``s``s`ksk``s``s`ksk```sii``s``s`kski```s``s`kski``s``s`ksk```sii``s``s`kski", -- 150 158 | SLit $ LitStr "````s``s`ksk```sii``s``s`kski````sii``s``s`ksk``s``s`kski`s``s`ksk```s``siii``s``s`kski", -- 151 159 | SLit $ LitStr "`````sii``s``s`ksk``s``s`kski`s``s`ksk```s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 152 160 | SLit $ LitStr "``s`k```s``s`kski``s``s`ksk``s``s`kski``s``s`ksk```s``siii``s``s`kski", -- 153 161 | SLit $ LitStr "`````s``s`kski``s``s`ksk``s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 154 162 | SLit $ LitStr "````s``s`kski````s`s``s`ksk``sii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 155 163 | SLit $ LitStr "``s``s`ksk````s``s`kski````s`s``s`ksk``sii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 156 164 | SLit $ LitStr "````s``s`kski```s``s`ksk```s`s``s`ksk``sii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 157 165 | SLit $ LitStr "``s`k``s``s`kski````s``s`ksk``s``s`kski```s``s`ksk```s``s`kski``s``s`ksk```sii``s``s`kski`s``s`kski", -- 158 166 | SLit $ LitStr "`````sii``s``s`kski`````s``s`kski````s``siii``s``s`kski`s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 159 167 | SLit $ LitStr "``s`k``s``s`kski``s`k``s``s`ksk```sii``s``s`kski```s``siii``s``s`kski", -- 160 168 | SLit $ LitStr "````s``s`kski```s``s`ksk```sii``s``s`kski````s``siii``s``s`kski`s``s`kski", -- 161 169 | SLit $ LitStr "``s`k``s``s`kski```s``sii`s``s`ksk``s``s`kski", -- 162 170 | SLit $ LitStr "````s``s`kski````s``sii`s``s`ksk``s``s`kski`s``s`kski", -- 163 171 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 164 172 | SLit $ LitStr "````s``s`kski```s``s`ksk```s``sii`s``s`ksk``s``s`kski`s``s`kski", -- 165 173 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk``s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 166 174 | SLit $ LitStr "````s``s`kski```s``s`ksk``s``s`ksk```s``sii`s``s`ksk``s``s`kski`s``s`kski", -- 167 175 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk``s``s`ksk``s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 168 176 | SLit $ LitStr "```s``s`kski````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`kski", -- 169 177 | SLit $ LitStr "``s``s`ksk```s``s`kski````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`kski", -- 170 178 | SLit $ LitStr "``s``s`ksk``s``s`ksk```s``s`kski````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`kski", -- 171 179 | SLit $ LitStr "``s`k```sii``s``s`kski`````s``siii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 172 180 | SLit $ LitStr "`````sii``s``s`kski``````s``siii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 173 181 | SLit $ LitStr "``s`k``s``s`ksk``s``s`ksk```sii``s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 174 182 | SLit $ LitStr "``s`k``s``s`ksk```sii``s``s`kski````s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 175 183 | SLit $ LitStr "``s`k````s``s`kski```s``s`ksk```sii``s``s`kski`s``s`kski```s``siii``s``s`kski", -- 176 184 | SLit $ LitStr "``````s``s`kski```s``s`ksk```sii``s``s`kski`s``s`kski````s``siii``s``s`kski`s``s`kski", -- 177 185 | SLit $ LitStr "````s``s`kski````s``sii`s``s`ksk``s``s`kski`s``s`ksk```s``siii``s``s`kski", -- 178 186 | SLit $ LitStr "``s``s`ksk````s``s`kski````s``sii`s``s`ksk``s``s`kski`s``s`ksk```s``siii``s``s`kski", -- 179 187 | SLit $ LitStr "``s`k``s``s`ksk```sii``s``s`kski```s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`kski", -- 180 188 | SLit $ LitStr "````s``s`ksk```sii``s``s`kski````s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`kski`s``s`kski", -- 181 189 | SLit $ LitStr "``s`k``s``s`kski`````sii``s``s`ksk``s``s`kski`s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 182 190 | SLit $ LitStr "````s``s`kski``````sii``s``s`ksk``s``s`kski`s``s`ksk```s`s``s`ksk``sii``s``s`kski`s``s`kski", -- 183 191 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk`````sii``s``s`ksk``s``s`kski`s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 184 192 | SLit $ LitStr "`````s``siii``s``s`kski`s``s`ksk```s``s`kski````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`kski", -- 185 193 | SLit $ LitStr "``s`k``s``s`kski````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 186 194 | SLit $ LitStr "``s`k````s``s`kski```s``s`ksk```sii``s``s`kski`s``s`kski``s``s`ksk```s``siii``s``s`kski", -- 187 195 | SLit $ LitStr "``````s``s`kski```s``s`ksk```sii``s``s`kski`s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 188 196 | SLit $ LitStr "````s``s`kski````s``sii`s``s`ksk``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 189 197 | SLit $ LitStr "``s``s`ksk````s``s`kski````s``sii`s``s`ksk``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 190 198 | SLit $ LitStr "````s``s`kski```s``s`ksk```s``sii`s``s`ksk``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 191 199 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski```s`s``s`ksk``sii``s``s`kski", -- 192 200 | SLit $ LitStr "````s``s`ksk``s``s`kski````s`s``s`ksk``sii``s``s`kski`s``s`kski", -- 193 201 | SLit $ LitStr "``s``s`ksk````s``s`ksk``s``s`kski````s`s``s`ksk``sii``s``s`kski`s``s`kski", -- 194 202 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski``s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 195 203 | SLit $ LitStr "```s``s`kski``s``s`ksk````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`kski", -- 196 204 | SLit $ LitStr "``s``s`ksk```s``s`kski``s``s`ksk````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`kski", -- 197 205 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski``s``s`ksk``s``s`ksk```s`s``s`ksk``sii``s``s`kski", -- 198 206 | SLit $ LitStr "````s``s`ksk``s``s`kski```s``s`ksk``s``s`ksk```s`s``s`ksk``sii``s``s`kski`s``s`kski", -- 199 207 | SLit $ LitStr "``s`k``s``s`kski```s``s`kski``s`k``s``s`kski``s``s`ksk```sii``s``s`kski", -- 200 208 | SLit $ LitStr "````s``s`kski````s``s`kski``s`k``s``s`kski``s``s`ksk```sii``s``s`kski`s``s`kski", -- 201 209 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk```s``s`kski``s`k``s``s`kski``s``s`ksk```sii``s``s`kski", -- 202 210 | SLit $ LitStr "````s``s`kski```s``s`ksk```s``s`kski``s`k``s``s`kski``s``s`ksk```sii``s``s`kski`s``s`kski", -- 203 211 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski``s`k```sii``s``s`kski``s``s`ksk```s``siii``s``s`kski", -- 204 212 | SLit $ LitStr "````s``s`ksk``s``s`kski````sii``s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 205 213 | SLit $ LitStr "`````s``sii`s``s`ksk``s``s`kski`s``s`ksk```s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 206 214 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski`````sii``s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 207 215 | SLit $ LitStr "``s`k````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`kski```s``siii``s``s`kski", -- 208 216 | SLit $ LitStr "````s``s`kski````s`s``s`ksk``sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 209 217 | SLit $ LitStr "``s``s`ksk````s``s`kski````s`s``s`ksk``sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 210 218 | SLit $ LitStr "````s``s`kski```s``s`ksk```s`s``s`ksk``sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 211 219 | SLit $ LitStr "``s`k``s``s`kski`````s``s`kski``s``s`ksk```sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 212 220 | SLit $ LitStr "`````sii``s``s`kski`````s``s`kski````s``siii``s``s`kski`s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 213 221 | SLit $ LitStr "``s`k``s``s`kski````s``s`ksk```sii``s``s`kski````s``siii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 214 222 | SLit $ LitStr "``s`k``s``s`ksk```sii``s``s`kski`````s``siii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 215 223 | SLit $ LitStr "```s``s`ksk``s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`kski", -- 216 224 | SLit $ LitStr "``s``s`ksk```s``s`ksk``s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`kski", -- 217 225 | SLit $ LitStr "``s`k``s``s`kski`````sii``s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski", -- 218 226 | SLit $ LitStr "````s``s`kski``````sii``s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski`s``s`kski", -- 219 227 | SLit $ LitStr "``s`k```sii``s``s`kski````s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski", -- 220 228 | SLit $ LitStr "`````sii``s``s`kski`````s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski`s``s`kski", -- 221 229 | SLit $ LitStr "``s``s`ksk`````sii``s``s`kski`````s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski`s``s`kski", -- 222 230 | SLit $ LitStr "``s``s`ksk``s``s`ksk`````sii``s``s`kski`````s``s`kski````sii``s``s`ksk``s``s`kski`s``s`kski`s``s`kski", -- 223 231 | SLit $ LitStr "``s`k``s``s`kski``s`k```sii``s``s`kski``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 224 232 | SLit $ LitStr "```s``s`kski``s`k``s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 225 233 | SLit $ LitStr "``s``s`ksk```s``s`kski``s`k``s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 226 234 | SLit $ LitStr "``s``s`ksk``s``s`ksk```s``s`kski``s`k``s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 227 235 | SLit $ LitStr "``s`k```sii``s``s`kski````s``s`kski```s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 228 236 | SLit $ LitStr "`````sii``s``s`kski`````s``s`kski```s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski`s``s`kski", -- 229 237 | SLit $ LitStr "``s``s`ksk`````sii``s``s`kski`````s``s`kski```s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski`s``s`kski", -- 230 238 | SLit $ LitStr "``s`k``s``s`ksk``s``s`ksk``s``s`ksk```sii``s``s`kski````s``s`kski````s``siii``s``s`kski`s``s`kski", -- 231 239 | SLit $ LitStr "``s`k``s``s`kski``s`k```sii``s``s`kski``s``s`ksk``s``s`ksk```sii``s``s`ksk``s``s`kski", -- 232 240 | SLit $ LitStr "````s``s`kski````sii``s``s`kski```s``s`ksk``s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 233 241 | SLit $ LitStr "``s`k```s``s`kski``s``s`ksk``s``s`kski``s``s`ksk```s``s`kski``s``s`ksk```sii``s``s`kski", -- 234 242 | SLit $ LitStr "`````s``s`kski``s``s`ksk``s``s`kski```s``s`ksk```s``s`kski``s``s`ksk```sii``s``s`kski`s``s`kski", -- 235 243 | SLit $ LitStr "``s`k```sii``s``s`kski````s``s`kski````s``siii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski", -- 236 244 | SLit $ LitStr "`````sii``s``s`kski`````s``s`kski````s``siii``s``s`kski`s``s`ksk```sii``s``s`ksk``s``s`kski`s``s`kski", -- 237 245 | SLit $ LitStr "``s`k``s``s`ksk````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`kski``s``s`ksk```s``siii``s``s`kski", -- 238 246 | SLit $ LitStr "````s``s`ksk````s``s`ksk``s``s`kski````sii``s``s`kski`s``s`kski```s``s`ksk```s``siii``s``s`kski`s``s`kski", -- 239 247 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski``s`k``s``s`ksk```sii``s``s`kski```s``siii``s``s`kski", -- 240 248 | SLit $ LitStr "````s``s`ksk``s``s`kski```s``s`ksk```sii``s``s`kski````s``siii``s``s`kski`s``s`kski", -- 241 249 | SLit $ LitStr "``s`k``s``s`kski```s``s`kski````s``s`kski```s``s`ksk```sii``s``s`kski`s``s`kski", -- 242 250 | SLit $ LitStr "```s``s`ksk```sii``s``s`kski``s``s`ksk``s``s`kski", -- 243 251 | SLit $ LitStr "``s``s`ksk```s``s`ksk```sii``s``s`kski``s``s`ksk``s``s`kski", -- 244 252 | SLit $ LitStr "``s``s`ksk``s``s`ksk```s``s`ksk```sii``s``s`kski``s``s`ksk``s``s`kski", -- 245 253 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski``s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 246 254 | SLit $ LitStr "````s``s`ksk``s``s`kski```s``s`ksk```s``sii`s``s`ksk``s``s`kski`s``s`kski", -- 247 255 | SLit $ LitStr "``s``s`ksk````s``s`ksk``s``s`kski```s``s`ksk```s``sii`s``s`ksk``s``s`kski`s``s`kski", -- 248 256 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski``s``s`ksk``s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 249 257 | SLit $ LitStr "``s`k``s``s`kski```s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 250 258 | SLit $ LitStr "````s``s`kski````s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski`s``s`kski", -- 251 259 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk```s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 252 260 | SLit $ LitStr "````s``s`kski```s``s`ksk```s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski`s``s`kski", -- 253 261 | SLit $ LitStr "``s`k``s``s`kski``s``s`ksk``s``s`ksk```s``s`ksk``s``s`kski``s``s`ksk```sii``s``s`kski", -- 254 262 | SLit $ LitStr "``s`k``s``s`ksk``s``s`kski`````sii``s``s`kski`s``s`ksk```s``sii`s``s`ksk``s``s`kski", -- 255 263 | SLit $ LitStr "```sii```sii``s``s`kski"] -- 256 264 | 265 | 266 | builtins = [ 267 | ("+", SLit $ LitStr "``si`k`s``s`ksk"), 268 | ("-", SLit $ LitStr "``s`k`s`k```sii``s``s`ks``s`k`s``si`k`kk``s`k`s`k`s``s`ksk``s``s`ks``s`kk``sii`k``s``s``si`k`kk``si`kii`k`k`ki``s`k`s``si`k``s``s``si`k`kk``si`kii``s`kk``s``si`k``s`k`sik`k`k`ki"), 269 | ("*", SLit $ LitStr "``s`ksk"), 270 | ("div", SLit $ LitStr "``s`k`s```ss`s``s`ks``s`kk``s`k`s``s`ks``s`kk``s``s`ks``s`k`s``si`k`kk`s`k`s``s`ksk`k`k`ki``s`kk``si`k``s``s``si`k`kk``si`kii`k``sii``s`kk``s`k`si``s`kk``s``si`k``s`k`sik`k`k`ki"), 271 | ("mod", SLit $ LitStr "``s`k`s```ss`s``s`ks``s`kk``s`k`s``s`ks``s``s`ks``s`kk``s`ks`s``si`k`kk`k``s`kk``s`k```sii``s``s`ks``s`k`s``si`k`kk``s`k`s`k`s``s`ksk``s``s`ks``s`kk``sii`k``s``s``si`k`kk``si`kii`k`k`ki``s``s``si`k`kk``si`kii``s`kk``si`k``s``s``si`k`kk``si`kii`k``sii``s`kk``s`k`si``s`kk``s``si`k``s`k`sik`k`k`ki"), 272 | ("&eq", SLit $ LitStr "``s`k`s`k``si`kk``s`k`s``si`k``si`k`ki``s`kk``s``si`k``s`k`s``si`k`kik`k``s``si`kk`k```sii``s`k``s`k`s``si`k`kik``sii"), 273 | ("&neq", SLit $ LitStr "``s`k`s`k``si`kk``s`k`s``si`k``si`k`ki``s`kk``s``si`k``s`k`s``si`kkk`k``s``si`k`ki`k```sii``s`k``s`k`s``si`kkk``sii"), 274 | ("<=", SLit $ LitStr "``s``s`ks``s`kk``s``si`k``s`k`sik`k`kk`k``s``si`k``s`k`sik`k`k`ki"), 275 | (">=", SLit $ LitStr "``s`k`s``s``si`k``s`k`sik`k`kk``s`kk``s``si`k``s`k`sik`k`k`ki"), 276 | ("<", SLit $ LitStr "``s`k`s``s``si`k``s`k`sik`k`k`ki``s`kk``s``si`k``s`k`sik`k`kk"), 277 | (">", SLit $ LitStr "``s``s`ks``s`kk``s``si`k``s`k`sik`k`k`ki`k``s``si`k``s`k`sik`k`kk"), 278 | ("&&", SLit $ LitStr "``ss`k`k`ki"), 279 | ("||", SLit $ LitStr "``si`kk"), 280 | (".", SLit $ LitStr "``s`ksk"), 281 | ("++", SLit $ LitStr "```sii``s``s`ks``s`k`s`ks``s`k`s``s`ksk``s`kk``s`k`s`k`s``s`ks``s`kk``s`k`s`k`s`kk``s``s`ks``s`kk``s`ks``s`k`sik`kk``s`k`s`kk``s``s`ks``s`kk``s`ks``sii`kk`k`ki"), 282 | ("Y", SLit $ LitStr "```ss`s``s`ksk`k``sii"), 283 | ("U", SLit $ LitStr "``s``s`ks``s``s`ksk`k``si`kk`k``si`k`ki"), 284 | ("cons", SLit $ LitStr "``s``s`ks``s`kk``s`ks``s`k`sik`kk"), 285 | ("nil", SLit $ LitStr "`kk"), 286 | ("IF", SVar "I"), 287 | ("ord", SVar "I"), 288 | ("chr", SVar "I")] 289 | 290 | skiError = SVar "I" 291 | 292 | expandBltin :: SKI -> SKI 293 | expandBltin (SAp (SVar "error") _) = skiError 294 | expandBltin (SAp e1 e2) = SAp (expandBltin e1) (expandBltin e2) 295 | expandBltin (SVar v) = case lookup v builtins of 296 | Just e -> e 297 | Nothing -> (SVar v) 298 | expandBltin (SLit (LitInt n)) = churchnums !! n 299 | expandBltin (SLit (LitChar (c:_))) = churchnums !! ord c 300 | -------------------------------------------------------------------------------- /Compiler.hs: -------------------------------------------------------------------------------- 1 | module Compiler where 2 | import Syntax 3 | import PatComp (compilePatternMatch) 4 | import PPrint () -- for (Show Expr) 5 | 6 | programToExpr :: Program -> Expr 7 | programToExpr bgs = foldr Let (mainExpr (last bgs)) bgs' 8 | where bgs' = regroup (init bgs) 9 | mainExpr :: BindGroup -> Expr 10 | mainExpr bg = case bindings bg of 11 | [("@main", [([], Rhs e)])] -> e 12 | _ -> error "Illegal program entry point" 13 | 14 | regroup :: [BindGroup] -> [BindGroup] 15 | regroup bgs = [([], [is]) | is <- iss] 16 | where iss = dependency (concat (map bindings bgs)) 17 | 18 | expandCon :: Expr -> Expr 19 | expandCon e@(Var _) = e 20 | expandCon e@(Lit _) = e 21 | expandCon (Ap e1 e2) = Ap (expandCon e1) (expandCon e2) 22 | expandCon (Let bg e) = Let (expandConBG bg) (expandCon e) 23 | expandCon (Lambda (vs, Rhs e)) = Lambda (vs, Rhs (expandCon e)) 24 | expandCon (ESign e sc) = (ESign (expandCon e) sc) 25 | expandCon (Con con) = Lambda ([PVar v | v <- as++fs], Rhs body) 26 | where as = ["@a" ++ show i | i <- [1..conArity con]] 27 | fs = ["@f" ++ show i | i <- [1..(tyconNumCon $ conTycon con)]] 28 | body = ap (Var $ fs !! (tag - 1)) [Var v | v <- as] 29 | tag = if conTag con < 1 then error ("bad tag " ++ conName con) else conTag con 30 | 31 | expandConBG :: BindGroup -> BindGroup 32 | expandConBG (es, iss) = (es', map expandConImpls iss) 33 | where es' = [(i, sc, map expandConAlt alts) | (i, sc, alts) <- es] 34 | expandConImpls is = [(i, map expandConAlt alts) | (i, alts) <- is] 35 | expandConAlt (ps, rhs) = (ps, expandConRhs rhs) 36 | expandConRhs (Rhs e) = Rhs (expandCon e) 37 | expandConRhs (Where bg rhs) = Where (expandConBG bg) 38 | (expandConRhs rhs) 39 | expandConRhs (Guarded pairs) = Guarded [(expandCon c, expandCon e) 40 | | (c, e) <- pairs] 41 | 42 | skiCompile :: Expr -> SKI 43 | skiCompile = compileExpr 44 | 45 | compileExpr :: Expr -> SKI 46 | compileExpr (Ap e1 e2) = compileExpr e1 `SAp` compileExpr e2 47 | compileExpr (Let bg e) 48 | = case map compileDef (bindings bg) of 49 | [(i, v)] -> case (abstract i e') of 50 | SVar "K" `SAp` _ -> e' 51 | e'' -> e'' `SAp` removeSelfRec i v 52 | defs -> compileMultipleDefs e' defs 53 | where e' = compileExpr e 54 | compileExpr (Lambda a) = compileAlt a 55 | compileExpr (Var i) = SVar i 56 | compileExpr (Lit l) = SLit l 57 | compileExpr (Con con) = SCon (conTag con) (conArity con) 58 | compileExpr e = error ("compileExpr: " ++ show e) 59 | 60 | compileDef :: (Id, [Alt]) -> (Id, SKI) 61 | compileDef (i, [a]) = (i, compileAlt a) 62 | 63 | removeSelfRec :: Id -> SKI -> SKI 64 | removeSelfRec i e 65 | | refers i e = SVar "Y" `SAp` abstract i e 66 | | otherwise = e 67 | 68 | compileMultipleDefs :: SKI -> [(Id, SKI)] -> SKI 69 | compileMultipleDefs e defs 70 | | not $ any (flip refers e) (map fst defs) = e 71 | | otherwise = SAp lhs rhs 72 | where (is, vals) = unzip defs 73 | lhs = uAbs is e 74 | rhs = SVar "Y" `SAp` uAbs is (mklist vals) 75 | mklist [] = SVar "nil" 76 | mklist (x:xs) = SVar "cons" `SAp` x `SAp` mklist xs 77 | 78 | uAbs :: [Id] -> SKI -> SKI 79 | uAbs [] e = SVar "K" `SAp` e 80 | uAbs (i:is) e = SVar "U" `SAp` abstract i (uAbs is e) 81 | 82 | compileAlt :: Alt -> SKI 83 | compileAlt ([], Rhs e) = compileExpr e 84 | compileAlt (PVar v : as, e) = abstract v (compileAlt (as, e)) 85 | compileAlt (p:ps, e) = error ("malformed pattern " ++ show p) 86 | 87 | abstract :: Id -> SKI -> SKI 88 | abstract i v@(SVar i') | i == i' = SVar "I" 89 | | otherwise = SVar "K" `SAp` v 90 | abstract i (SAp e1 e2) 91 | | refers i e1 || refers i e2 = 92 | sap (SVar "S") [abstract i e1, abstract i e2] 93 | | otherwise = 94 | SAp (SVar "K") (SAp e1 e2) 95 | abstract i l@(SLit _) = SVar "K" `SAp` l 96 | abstract i c@(SCon _ _) = SVar "K" `SAp` c 97 | 98 | refers :: Id -> SKI -> Bool 99 | refers i (SVar i') = i == i' 100 | refers i (SAp e1 e2) = refers i e1 || refers i e2 101 | refers i (SLit _) = False 102 | refers i (SCon _ _) = False 103 | -------------------------------------------------------------------------------- /Lexer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LINE 2 "Lexer.x" #-} 3 | 4 | module Lexer where 5 | import Numeric (readOct, readHex) 6 | import Data.Char (isUpper, isLower) 7 | import qualified Text.ParserCombinators.Parsec.Pos as Pos 8 | 9 | #if __GLASGOW_HASKELL__ >= 603 10 | #include "ghcconfig.h" 11 | #elif defined(__GLASGOW_HASKELL__) 12 | #include "config.h" 13 | #endif 14 | #if __GLASGOW_HASKELL__ >= 503 15 | import Data.Array 16 | import Data.Char (ord) 17 | import Data.Array.Base (unsafeAt) 18 | #else 19 | import Array 20 | import Char (ord) 21 | #endif 22 | {-# LINE 1 "templates/wrappers.hs" #-} 23 | {-# LINE 1 "templates/wrappers.hs" #-} 24 | {-# LINE 1 "" #-} 25 | {-# LINE 1 "" #-} 26 | {-# LINE 1 "templates/wrappers.hs" #-} 27 | -- ----------------------------------------------------------------------------- 28 | -- Alex wrapper code. 29 | -- 30 | -- This code is in the PUBLIC DOMAIN; you may copy it freely and use 31 | -- it for any purpose whatsoever. 32 | 33 | import Data.Word (Word8) 34 | {-# LINE 22 "templates/wrappers.hs" #-} 35 | 36 | import qualified Data.Bits 37 | 38 | -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. 39 | utf8Encode :: Char -> [Word8] 40 | utf8Encode = map fromIntegral . go . ord 41 | where 42 | go oc 43 | | oc <= 0x7f = [oc] 44 | 45 | | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) 46 | , 0x80 + oc Data.Bits..&. 0x3f 47 | ] 48 | 49 | | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) 50 | , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) 51 | , 0x80 + oc Data.Bits..&. 0x3f 52 | ] 53 | | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) 54 | , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) 55 | , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) 56 | , 0x80 + oc Data.Bits..&. 0x3f 57 | ] 58 | 59 | 60 | 61 | type Byte = Word8 62 | 63 | -- ----------------------------------------------------------------------------- 64 | -- The input type 65 | 66 | 67 | type AlexInput = (AlexPosn, -- current position, 68 | Char, -- previous char 69 | [Byte], -- pending bytes on current char 70 | String) -- current input string 71 | 72 | ignorePendingBytes (p,c,ps,s) = (p,c,s) 73 | 74 | alexInputPrevChar :: AlexInput -> Char 75 | alexInputPrevChar (p,c,bs,s) = c 76 | 77 | alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) 78 | alexGetByte (p,c,(b:bs),s) = Just (b,(p,c,bs,s)) 79 | alexGetByte (p,c,[],[]) = Nothing 80 | alexGetByte (p,_,[],(c:s)) = let p' = alexMove p c 81 | (b:bs) = utf8Encode c 82 | in p' `seq` Just (b, (p', c, bs, s)) 83 | 84 | 85 | {-# LINE 88 "templates/wrappers.hs" #-} 86 | 87 | {-# LINE 102 "templates/wrappers.hs" #-} 88 | 89 | {-# LINE 117 "templates/wrappers.hs" #-} 90 | 91 | -- ----------------------------------------------------------------------------- 92 | -- Token positions 93 | 94 | -- `Posn' records the location of a token in the input text. It has three 95 | -- fields: the address (number of chacaters preceding the token), line number 96 | -- and column of a token within the file. `start_pos' gives the position of the 97 | -- start of the file and `eof_pos' a standard encoding for the end of file. 98 | -- `move_pos' calculates the new position after traversing a given character, 99 | -- assuming the usual eight character tab stops. 100 | 101 | 102 | data AlexPosn = AlexPn !Int !Int !Int 103 | deriving (Eq,Show) 104 | 105 | alexStartPos :: AlexPosn 106 | alexStartPos = AlexPn 0 1 1 107 | 108 | alexMove :: AlexPosn -> Char -> AlexPosn 109 | alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1) 110 | alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1 111 | alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) 112 | 113 | 114 | -- ----------------------------------------------------------------------------- 115 | -- Default monad 116 | 117 | {-# LINE 230 "templates/wrappers.hs" #-} 118 | 119 | 120 | -- ----------------------------------------------------------------------------- 121 | -- Monad (with ByteString input) 122 | 123 | {-# LINE 319 "templates/wrappers.hs" #-} 124 | 125 | 126 | -- ----------------------------------------------------------------------------- 127 | -- Basic wrapper 128 | 129 | {-# LINE 345 "templates/wrappers.hs" #-} 130 | 131 | 132 | -- ----------------------------------------------------------------------------- 133 | -- Basic wrapper, ByteString version 134 | 135 | {-# LINE 363 "templates/wrappers.hs" #-} 136 | 137 | {-# LINE 376 "templates/wrappers.hs" #-} 138 | 139 | 140 | -- ----------------------------------------------------------------------------- 141 | -- Posn wrapper 142 | 143 | -- Adds text positions to the basic model. 144 | 145 | 146 | --alexScanTokens :: String -> [token] 147 | alexScanTokens str = go (alexStartPos,'\n',[],str) 148 | where go inp@(pos,_,_,str) = 149 | case alexScan inp 0 of 150 | AlexEOF -> [] 151 | AlexError ((AlexPn _ line column),_,_,_) -> error $ "lexical error at " ++ (show line) ++ " line, " ++ (show column) ++ " column" 152 | AlexSkip inp' len -> go inp' 153 | AlexToken inp' len act -> act pos (take len str) : go inp' 154 | 155 | 156 | 157 | -- ----------------------------------------------------------------------------- 158 | -- Posn wrapper, ByteString version 159 | 160 | {-# LINE 408 "templates/wrappers.hs" #-} 161 | 162 | 163 | -- ----------------------------------------------------------------------------- 164 | -- GScan wrapper 165 | 166 | -- For compatibility with previous versions of Alex, and because we can. 167 | 168 | alex_base :: Array Int Int 169 | alex_base = listArray (0,62) [-8,76,-33,80,99,204,415,543,671,799,927,1055,1183,1296,0,1424,0,1537,0,1650,0,270,0,1715,0,1780,2036,1972,0,0,2085,2341,2460,2465,2392,0,2648,2742,2829,2765,0,0,2883,3107,3187,-41,3352,3288,0,113,3534,3745,-30,0,3497,109,-32,3512,0,0,3962,2448,4052] 170 | 171 | alex_table :: Array Int Int 172 | alex_table = listArray (0,4307) [0,49,49,49,49,49,58,56,56,56,56,56,56,56,56,6,56,56,56,56,56,56,56,56,49,62,43,62,62,62,62,38,53,53,62,62,53,61,62,62,54,55,55,55,55,55,55,55,55,55,62,53,62,62,62,62,62,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,53,62,53,-1,53,0,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,52,62,53,62,58,0,1,49,49,49,49,49,0,2,2,2,2,2,2,2,2,2,2,58,0,0,0,0,0,0,49,0,3,3,3,3,3,3,3,3,3,3,55,55,55,55,55,55,55,55,55,55,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,51,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,26,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,27,10,20,20,20,20,20,20,20,20,20,20,20,20,20,20,21,15,14,14,14,13,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,46,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,1,27,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,26,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,27,10,20,20,20,20,20,20,20,20,20,20,20,20,20,20,21,15,14,14,14,13,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,5,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,41,36,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,31,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,26,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,8,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,9,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,21,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,10,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,23,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,25,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,34,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,39,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,42,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,32,32,32,32,32,32,32,32,32,32,0,0,62,0,62,62,62,62,0,0,0,62,62,32,50,62,62,0,32,0,43,0,0,0,0,43,0,62,0,62,62,62,62,62,43,43,43,43,43,43,43,43,43,43,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,62,0,0,0,0,0,0,0,0,0,0,0,43,0,0,0,0,43,0,0,0,0,43,43,0,0,0,43,0,0,0,0,62,0,62,43,0,0,0,43,0,43,0,43,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,2,0,0,0,0,2,0,0,0,0,0,0,0,0,4,4,4,4,4,4,4,4,4,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,0,0,0,0,2,2,0,0,0,2,0,0,0,0,0,0,0,2,0,0,0,2,0,2,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,37,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,36,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,40,39,8,24,24,24,24,24,24,24,24,24,24,24,24,24,24,25,11,18,18,18,19,47,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,43,43,59,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,33,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,43,57,57,57,57,57,57,57,57,57,57,0,0,0,0,0,0,0,57,57,57,57,57,57,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,57,57,57,57,57,57,0,0,0,0,0,0,0,0,0,0,0,31,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,35,34,9,22,22,22,22,22,22,22,22,22,22,22,22,22,22,23,12,16,16,16,17,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,55,55,55,55,55,55,55,55,55,55,0,0,0,0,0,57,57,57,57,57,57,57,57,57,57,0,0,0,0,0,0,45,57,57,57,57,57,57,0,0,44,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,45,57,57,57,57,57,57,0,0,44,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,46,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,47,5,41,41,41,41,41,41,41,41,41,41,41,41,41,41,42,7,29,29,29,30,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,26,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,27,10,20,20,20,20,20,20,20,20,20,20,20,20,20,20,21,15,14,14,14,13,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,60,0,0,0,0,0,0,0,0,60,60,60,60,60,60,60,60,60,60,0,0,0,0,0,0,0,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,0,0,0,0,60,0,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,62,0,62,62,62,62,0,0,0,62,62,0,62,62,62,0,0,0,0,0,0,0,0,0,0,62,0,62,62,62,62,62,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,62,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,62,0,62,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] 173 | 174 | alex_check :: Array Int Int 175 | alex_check = listArray (0,4307) [-1,9,10,11,12,13,39,48,49,50,51,52,53,54,55,45,48,49,50,51,52,53,54,55,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,10,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,39,-1,45,9,10,11,12,13,-1,48,49,50,51,52,53,54,55,56,57,39,-1,-1,-1,-1,-1,-1,32,-1,48,49,50,51,52,53,54,55,56,57,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,125,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,45,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,9,10,11,12,13,9,10,11,12,13,-1,-1,33,-1,35,36,37,38,-1,-1,-1,42,43,32,45,46,47,-1,32,-1,34,-1,-1,-1,-1,39,-1,58,-1,60,61,62,63,64,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,92,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,92,-1,-1,-1,-1,92,-1,-1,-1,-1,97,98,-1,-1,-1,102,-1,-1,-1,-1,124,-1,126,110,-1,-1,-1,114,-1,116,-1,118,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,34,-1,-1,-1,-1,39,-1,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,92,-1,-1,-1,-1,97,98,-1,-1,-1,102,-1,-1,-1,-1,-1,-1,-1,110,-1,-1,-1,114,-1,116,-1,118,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,-1,-1,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,97,98,99,100,101,102,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,10,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,79,65,66,67,68,69,70,-1,-1,88,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,111,97,98,99,100,101,102,-1,-1,120,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,45,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,39,-1,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,33,-1,35,36,37,38,-1,-1,-1,42,43,-1,45,46,47,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,58,-1,60,61,62,63,64,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,92,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,124,-1,126,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1] 176 | 177 | alex_deflt :: Array Int Int 178 | alex_deflt = listArray (0,62) [-1,6,-1,-1,-1,-1,6,-1,-1,-1,-1,-1,-1,20,20,-1,22,22,24,24,28,28,35,35,40,40,6,6,6,41,41,43,-1,-1,43,43,2,-1,-1,2,2,48,48,-1,-1,-1,50,50,50,-1,50,6,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1] 179 | 180 | alex_accept = listArray (0::Int,62) [[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_10))]] 181 | {-# LINE 33 "Lexer.x" #-} 182 | 183 | 184 | single = mtk (single' . head) 185 | dec = mtk (TokenInt . read) 186 | oct = mtk (TokenInt . fst . head . readOct . drop 2) 187 | hex = mtk (TokenInt . fst . head . readHex . drop 2) 188 | ch = mtk (TokenChar . unescapeLit) 189 | str = mtk (TokenStr . unescapeLit) 190 | ide = mtk ide' 191 | sym = mtk sym' 192 | 193 | unescapeLit = unescape . init . tail 194 | unescape [] = [] 195 | unescape ('\\':'a':cs) = '\a' : unescape cs 196 | unescape ('\\':'b':cs) = '\b' : unescape cs 197 | unescape ('\\':'f':cs) = '\f' : unescape cs 198 | unescape ('\\':'n':cs) = '\n' : unescape cs 199 | unescape ('\\':'r':cs) = '\r' : unescape cs 200 | unescape ('\\':'t':cs) = '\t' : unescape cs 201 | unescape ('\\':'v':cs) = '\v' : unescape cs 202 | unescape ('\\':c:cs) = c : unescape cs 203 | unescape (c:cs) = c : unescape cs 204 | 205 | single' '(' = TokenLParen 206 | single' ')' = TokenRParen 207 | single' '{' = TokenLBrace 208 | single' '}' = TokenRBrace 209 | single' '[' = TokenLBracket 210 | single' ']' = TokenRBracket 211 | single' ',' = TokenComma 212 | single' ';' = TokenSemicolon 213 | single' '_' = TokenWildcard 214 | 215 | ide' "if" = TokenIf 216 | ide' "then" = TokenThen 217 | ide' "else" = TokenElse 218 | ide' "let" = TokenLet 219 | ide' "in" = TokenIn 220 | ide' "case" = TokenCase 221 | ide' "of" = TokenOf 222 | ide' "do" = TokenDo 223 | ide' "data" = TokenData 224 | ide' "type" = TokenType 225 | ide' "class" = TokenClass 226 | ide' "instance" = TokenInstance 227 | ide' "where" = TokenWhere 228 | ide' "import" = TokenImport 229 | ide' "hiding" = TokenHiding 230 | ide' s@(c:_) 231 | | isUpper c = TokenConId s 232 | | isLower c = TokenId s 233 | ide' s = error ("unknown token " ++ s) 234 | 235 | sym' ".." = TokenDotDot 236 | sym' "::" = TokenCoco 237 | sym' "=" = TokenEq 238 | sym' "\\" = TokenLambda 239 | sym' "|" = TokenBar 240 | sym' "<-" = TokenLArrow 241 | sym' "->" = TokenRArrow 242 | sym' "@" = TokenAt 243 | sym' "~" = TokenTilde 244 | sym' "=>" = TokenImply 245 | sym' s@(':':_) = TokenConOp s 246 | sym' s = TokenOp s 247 | 248 | mtk :: (String -> Token) -> AlexPosn -> String -> (Token, AlexPosn) 249 | mtk f p s = (f s, p) 250 | 251 | data Token = TokenId String 252 | | TokenConId String 253 | | TokenChar String 254 | | TokenStr String 255 | | TokenInt Int 256 | | TokenIf 257 | | TokenThen 258 | | TokenElse 259 | | TokenLet 260 | | TokenIn 261 | | TokenCase 262 | | TokenOf 263 | | TokenDo 264 | | TokenData 265 | | TokenType 266 | | TokenClass 267 | | TokenInstance 268 | | TokenWhere 269 | | TokenImport 270 | | TokenHiding 271 | 272 | | TokenDotDot 273 | | TokenCoco 274 | | TokenEq 275 | | TokenLambda 276 | | TokenBar 277 | | TokenLArrow 278 | | TokenRArrow 279 | | TokenAt 280 | | TokenTilde 281 | | TokenImply 282 | 283 | | TokenLParen 284 | | TokenRParen 285 | | TokenLBrace 286 | | TokenRBrace 287 | | TokenLBracket 288 | | TokenRBracket 289 | | TokenComma 290 | | TokenSemicolon 291 | | TokenWildcard 292 | 293 | | TokenOp String 294 | | TokenConOp String 295 | deriving (Show, Eq) 296 | 297 | lexer :: String -> String -> [(Token, Pos.SourcePos)] 298 | lexer fname = map parsecToken . layout . annotate . alexScanTokens 299 | where parsecToken (tok, AlexPn _ ln col) = (tok, Pos.newPos fname ln col) 300 | 301 | lexer' :: String -> String -> [(Token, Pos.SourcePos)] 302 | lexer' fname = map parsecToken . alexScanTokens 303 | where parsecToken (tok, AlexPn _ ln col) = (tok, Pos.newPos fname ln col) 304 | 305 | data AnToken = Layout Int 306 | | Indent Int 307 | | Token (Token, AlexPosn) 308 | 309 | annotate :: [(Token, AlexPosn)] -> [AnToken] 310 | annotate tps = annotate2 0 tps 311 | 312 | annotate1 :: Int -> [(Token, AlexPosn)] -> [AnToken] 313 | annotate1 line [] = [] 314 | annotate1 line (t@(tok, AlexPn _ ln col) : tps) 315 | | line < ln = Indent col : rest 316 | | otherwise = rest 317 | where rest = Token t : (next tok) ln tps 318 | next TokenLet = annotate2 319 | next TokenWhere = annotate2 320 | next TokenOf = annotate2 321 | next _ = annotate1 322 | 323 | annotate2 :: Int -> [(Token, AlexPosn)] -> [AnToken] 324 | annotate2 line tps@((TokenLBrace, _):_) = annotate1 line tps 325 | annotate2 line tps@((_, AlexPn _ ln col):_) = Layout col : annotate1 ln tps 326 | 327 | layout :: [AnToken] -> [(Token, AlexPosn)] 328 | layout ts = layout' ts [] 329 | 330 | nullPosn :: AlexPosn 331 | nullPosn = AlexPn 0 0 0 332 | 333 | layout' :: [AnToken] -> [Int] -> [(Token, AlexPosn)] 334 | layout' ts@(Indent n : ts') ms@(m:ms') 335 | | n == m = (TokenSemicolon, nullPosn) : layout' ts' ms 336 | | n < m = (TokenRBrace, nullPosn) : layout' ts ms' 337 | layout' (Indent n : ts) ms = layout' ts ms 338 | layout' (Layout n : ts) ms@(m:_) 339 | | n > m = (TokenLBrace, nullPosn) : layout' ts (n:ms) 340 | | otherwise = (TokenLBrace, nullPosn) 341 | : (TokenRBrace, nullPosn) 342 | : layout' (Indent n : ts) ms 343 | layout' (Layout n : ts) [] = (TokenLBrace, nullPosn) : layout' ts [n] 344 | layout' (Token t@(TokenRBrace, _) : ts) (0:ms) = t : layout' ts ms 345 | layout' (Token (TokenRBrace, _) : ts) ms = error "parse-error: `}' expected" 346 | layout' (Token t@(TokenLBrace, _) : ts) ms = t : layout' ts (0:ms) 347 | layout' (Token t : ts) ms = t : layout' ts ms 348 | layout' [] [] = [] 349 | layout' [] (m:ms) = (TokenRBrace, nullPosn) : layout' [] ms 350 | 351 | alex_action_3 = single 352 | alex_action_4 = dec 353 | alex_action_5 = oct 354 | alex_action_6 = hex 355 | alex_action_7 = ch 356 | alex_action_8 = str 357 | alex_action_9 = ide 358 | alex_action_10 = sym 359 | {-# LINE 1 "templates/GenericTemplate.hs" #-} 360 | {-# LINE 1 "templates/GenericTemplate.hs" #-} 361 | {-# LINE 1 "" #-} 362 | {-# LINE 1 "" #-} 363 | {-# LINE 1 "templates/GenericTemplate.hs" #-} 364 | -- ----------------------------------------------------------------------------- 365 | -- ALEX TEMPLATE 366 | -- 367 | -- This code is in the PUBLIC DOMAIN; you may copy it freely and use 368 | -- it for any purpose whatsoever. 369 | 370 | -- ----------------------------------------------------------------------------- 371 | -- INTERNALS and main scanner engine 372 | 373 | {-# LINE 37 "templates/GenericTemplate.hs" #-} 374 | 375 | {-# LINE 47 "templates/GenericTemplate.hs" #-} 376 | 377 | {-# LINE 68 "templates/GenericTemplate.hs" #-} 378 | alexIndexInt16OffAddr arr off = arr ! off 379 | 380 | 381 | {-# LINE 89 "templates/GenericTemplate.hs" #-} 382 | alexIndexInt32OffAddr arr off = arr ! off 383 | 384 | 385 | {-# LINE 100 "templates/GenericTemplate.hs" #-} 386 | quickIndex arr i = arr ! i 387 | 388 | 389 | -- ----------------------------------------------------------------------------- 390 | -- Main lexing routines 391 | 392 | data AlexReturn a 393 | = AlexEOF 394 | | AlexError !AlexInput 395 | | AlexSkip !AlexInput !Int 396 | | AlexToken !AlexInput !Int a 397 | 398 | -- alexScan :: AlexInput -> StartCode -> AlexReturn a 399 | alexScan input (sc) 400 | = alexScanUser undefined input (sc) 401 | 402 | alexScanUser user input (sc) 403 | = case alex_scan_tkn user input (0) input sc AlexNone of 404 | (AlexNone, input') -> 405 | case alexGetByte input of 406 | Nothing -> 407 | 408 | 409 | 410 | AlexEOF 411 | Just _ -> 412 | 413 | 414 | 415 | AlexError input' 416 | 417 | (AlexLastSkip input'' len, _) -> 418 | 419 | 420 | 421 | AlexSkip input'' len 422 | 423 | (AlexLastAcc k input''' len, _) -> 424 | 425 | 426 | 427 | AlexToken input''' len k 428 | 429 | 430 | -- Push the input through the DFA, remembering the most recent accepting 431 | -- state it encountered. 432 | 433 | alex_scan_tkn user orig_input len input s last_acc = 434 | input `seq` -- strict in the input 435 | let 436 | new_acc = (check_accs (alex_accept `quickIndex` (s))) 437 | in 438 | new_acc `seq` 439 | case alexGetByte input of 440 | Nothing -> (new_acc, input) 441 | Just (c, new_input) -> 442 | 443 | 444 | 445 | let 446 | (base) = alexIndexInt32OffAddr alex_base s 447 | ((ord_c)) = fromIntegral c 448 | (offset) = (base + ord_c) 449 | (check) = alexIndexInt16OffAddr alex_check offset 450 | 451 | (new_s) = if (offset >= (0)) && (check == ord_c) 452 | then alexIndexInt16OffAddr alex_table offset 453 | else alexIndexInt16OffAddr alex_deflt s 454 | in 455 | case new_s of 456 | (-1) -> (new_acc, input) 457 | -- on an error, we want to keep the input *before* the 458 | -- character that failed, not after. 459 | _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len + (1)) else len) 460 | -- note that the length is increased ONLY if this is the 1st byte in a char encoding) 461 | new_input new_s new_acc 462 | 463 | where 464 | check_accs [] = last_acc 465 | check_accs (AlexAcc a : _) = AlexLastAcc a input (len) 466 | check_accs (AlexAccSkip : _) = AlexLastSkip input (len) 467 | check_accs (AlexAccPred a predx : rest) 468 | | predx user orig_input (len) input 469 | = AlexLastAcc a input (len) 470 | check_accs (AlexAccSkipPred predx : rest) 471 | | predx user orig_input (len) input 472 | = AlexLastSkip input (len) 473 | check_accs (_ : rest) = check_accs rest 474 | 475 | data AlexLastAcc a 476 | = AlexNone 477 | | AlexLastAcc a !AlexInput !Int 478 | | AlexLastSkip !AlexInput !Int 479 | 480 | instance Functor AlexLastAcc where 481 | fmap f AlexNone = AlexNone 482 | fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z 483 | fmap f (AlexLastSkip x y) = AlexLastSkip x y 484 | 485 | data AlexAcc a user 486 | = AlexAcc a 487 | | AlexAccSkip 488 | | AlexAccPred a (AlexAccPred user) 489 | | AlexAccSkipPred (AlexAccPred user) 490 | 491 | type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool 492 | 493 | -- ----------------------------------------------------------------------------- 494 | -- Predicates on a rule 495 | 496 | alexAndPred p1 p2 user in1 len in2 497 | = p1 user in1 len in2 && p2 user in1 len in2 498 | 499 | --alexPrevCharIsPred :: Char -> AlexAccPred _ 500 | alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input 501 | 502 | alexPrevCharMatches f _ input _ _ = f (alexInputPrevChar input) 503 | 504 | --alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ 505 | alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input 506 | 507 | --alexRightContext :: Int -> AlexAccPred _ 508 | alexRightContext (sc) user _ _ input = 509 | case alex_scan_tkn user input (0) input sc AlexNone of 510 | (AlexNone, _) -> False 511 | _ -> True 512 | -- TODO: there's no need to find the longest 513 | -- match when checking the right context, just 514 | -- the first match will do. 515 | 516 | -- used by wrappers 517 | iUnbox (i) = i 518 | -------------------------------------------------------------------------------- /Lexer.x: -------------------------------------------------------------------------------- 1 | --*- Haskell -*- 2 | { 3 | module Lexer where 4 | import Numeric (readOct, readHex) 5 | import Data.Char (isUpper, isLower) 6 | import qualified Text.ParserCombinators.Parsec.Pos as Pos 7 | } 8 | 9 | %wrapper "posn" 10 | 11 | $l = [a-zA-Z] -- letters 12 | $d = 0-9 -- digits 13 | $i = [$l$d\_\'] -- identifier character 14 | $s = [!\#\$\%&\*\+\-\.\/:\<=>\?@\\\|\~] -- symbolic char 15 | @e = \\([abfnrtv\"\'\\]|$d{1,3}) -- character escape 16 | @c = $printable#[\"\\]|@e -- string character 17 | @g = \\$white+\\ -- string gap 18 | 19 | tokens :- 20 | 21 | $white+ ; -- white space 22 | "--".* ; -- line comment 23 | "{-"([~\-]|\-+[~\-\}]|\n)*\-+\} ; -- comment 24 | [\,\(\)\[\]_\{\;\}] { single } -- single char token 25 | $d+ { dec } -- signed integer literal 26 | 0[oO][0-7]+ { oct } -- signed octal literal 27 | 0[xX][0-9a-fA-F]+ { hex } -- signed hexadecimal literal 28 | \'(@c|\")\' { ch } -- character literal 29 | \"(@c|@g)*\" { str } -- string literal 30 | $l$i* { ide } -- alphabetic identifier 31 | $s+ { sym } -- symbolic identifier 32 | 33 | { 34 | 35 | single = mtk (single' . head) 36 | dec = mtk (TokenInt . read) 37 | oct = mtk (TokenInt . fst . head . readOct . drop 2) 38 | hex = mtk (TokenInt . fst . head . readHex . drop 2) 39 | ch = mtk (TokenChar . unescapeLit) 40 | str = mtk (TokenStr . unescapeLit) 41 | ide = mtk ide' 42 | sym = mtk sym' 43 | 44 | unescapeLit = unescape . init . tail 45 | unescape [] = [] 46 | unescape ('\\':'a':cs) = '\a' : unescape cs 47 | unescape ('\\':'b':cs) = '\b' : unescape cs 48 | unescape ('\\':'f':cs) = '\f' : unescape cs 49 | unescape ('\\':'n':cs) = '\n' : unescape cs 50 | unescape ('\\':'r':cs) = '\r' : unescape cs 51 | unescape ('\\':'t':cs) = '\t' : unescape cs 52 | unescape ('\\':'v':cs) = '\v' : unescape cs 53 | unescape ('\\':c:cs) = c : unescape cs 54 | unescape (c:cs) = c : unescape cs 55 | 56 | single' '(' = TokenLParen 57 | single' ')' = TokenRParen 58 | single' '{' = TokenLBrace 59 | single' '}' = TokenRBrace 60 | single' '[' = TokenLBracket 61 | single' ']' = TokenRBracket 62 | single' ',' = TokenComma 63 | single' ';' = TokenSemicolon 64 | single' '_' = TokenWildcard 65 | 66 | ide' "if" = TokenIf 67 | ide' "then" = TokenThen 68 | ide' "else" = TokenElse 69 | ide' "let" = TokenLet 70 | ide' "in" = TokenIn 71 | ide' "case" = TokenCase 72 | ide' "of" = TokenOf 73 | ide' "do" = TokenDo 74 | ide' "data" = TokenData 75 | ide' "type" = TokenType 76 | ide' "class" = TokenClass 77 | ide' "instance" = TokenInstance 78 | ide' "where" = TokenWhere 79 | ide' "import" = TokenImport 80 | ide' "hiding" = TokenHiding 81 | ide' s@(c:_) 82 | | isUpper c = TokenConId s 83 | | isLower c = TokenId s 84 | ide' s = error ("unknown token " ++ s) 85 | 86 | sym' ".." = TokenDotDot 87 | sym' "::" = TokenCoco 88 | sym' "=" = TokenEq 89 | sym' "\\" = TokenLambda 90 | sym' "|" = TokenBar 91 | sym' "<-" = TokenLArrow 92 | sym' "->" = TokenRArrow 93 | sym' "@" = TokenAt 94 | sym' "~" = TokenTilde 95 | sym' "=>" = TokenImply 96 | sym' s@(':':_) = TokenConOp s 97 | sym' s = TokenOp s 98 | 99 | mtk :: (String -> Token) -> AlexPosn -> String -> (Token, AlexPosn) 100 | mtk f p s = (f s, p) 101 | 102 | data Token = TokenId String 103 | | TokenConId String 104 | | TokenChar String 105 | | TokenStr String 106 | | TokenInt Int 107 | | TokenIf 108 | | TokenThen 109 | | TokenElse 110 | | TokenLet 111 | | TokenIn 112 | | TokenCase 113 | | TokenOf 114 | | TokenDo 115 | | TokenData 116 | | TokenType 117 | | TokenClass 118 | | TokenInstance 119 | | TokenWhere 120 | | TokenImport 121 | | TokenHiding 122 | 123 | | TokenDotDot 124 | | TokenCoco 125 | | TokenEq 126 | | TokenLambda 127 | | TokenBar 128 | | TokenLArrow 129 | | TokenRArrow 130 | | TokenAt 131 | | TokenTilde 132 | | TokenImply 133 | 134 | | TokenLParen 135 | | TokenRParen 136 | | TokenLBrace 137 | | TokenRBrace 138 | | TokenLBracket 139 | | TokenRBracket 140 | | TokenComma 141 | | TokenSemicolon 142 | | TokenWildcard 143 | 144 | | TokenOp String 145 | | TokenConOp String 146 | deriving (Show, Eq) 147 | 148 | lexer :: String -> String -> [(Token, Pos.SourcePos)] 149 | lexer fname = map parsecToken . layout . annotate . alexScanTokens 150 | where parsecToken (tok, AlexPn _ ln col) = (tok, Pos.newPos fname ln col) 151 | 152 | lexer' :: String -> String -> [(Token, Pos.SourcePos)] 153 | lexer' fname = map parsecToken . alexScanTokens 154 | where parsecToken (tok, AlexPn _ ln col) = (tok, Pos.newPos fname ln col) 155 | 156 | data AnToken = Layout Int 157 | | Indent Int 158 | | Token (Token, AlexPosn) 159 | 160 | annotate :: [(Token, AlexPosn)] -> [AnToken] 161 | annotate tps = annotate2 0 tps 162 | 163 | annotate1 :: Int -> [(Token, AlexPosn)] -> [AnToken] 164 | annotate1 line [] = [] 165 | annotate1 line (t@(tok, AlexPn _ ln col) : tps) 166 | | line < ln = Indent col : rest 167 | | otherwise = rest 168 | where rest = Token t : (next tok) ln tps 169 | next TokenLet = annotate2 170 | next TokenWhere = annotate2 171 | next TokenOf = annotate2 172 | next _ = annotate1 173 | 174 | annotate2 :: Int -> [(Token, AlexPosn)] -> [AnToken] 175 | annotate2 line tps@((TokenLBrace, _):_) = annotate1 line tps 176 | annotate2 line tps@((_, AlexPn _ ln col):_) = Layout col : annotate1 ln tps 177 | 178 | layout :: [AnToken] -> [(Token, AlexPosn)] 179 | layout ts = layout' ts [] 180 | 181 | nullPosn :: AlexPosn 182 | nullPosn = AlexPn 0 0 0 183 | 184 | layout' :: [AnToken] -> [Int] -> [(Token, AlexPosn)] 185 | layout' ts@(Indent n : ts') ms@(m:ms') 186 | | n == m = (TokenSemicolon, nullPosn) : layout' ts' ms 187 | | n < m = (TokenRBrace, nullPosn) : layout' ts ms' 188 | layout' (Indent n : ts) ms = layout' ts ms 189 | layout' (Layout n : ts) ms@(m:_) 190 | | n > m = (TokenLBrace, nullPosn) : layout' ts (n:ms) 191 | | otherwise = (TokenLBrace, nullPosn) 192 | : (TokenRBrace, nullPosn) 193 | : layout' (Indent n : ts) ms 194 | layout' (Layout n : ts) [] = (TokenLBrace, nullPosn) : layout' ts [n] 195 | layout' (Token t@(TokenRBrace, _) : ts) (0:ms) = t : layout' ts ms 196 | layout' (Token (TokenRBrace, _) : ts) ms = error "parse-error: `}' expected" 197 | layout' (Token t@(TokenLBrace, _) : ts) ms = t : layout' ts (0:ms) 198 | layout' (Token t : ts) ms = t : layout' ts ms 199 | layout' [] [] = [] 200 | layout' [] (m:ms) = (TokenRBrace, nullPosn) : layout' [] ms 201 | } 202 | -------------------------------------------------------------------------------- /License.thih: -------------------------------------------------------------------------------- 1 | `Typing Haskell in Haskell' is Copyright (c) Mark P Jones 2 | and the Oregon Graduate Institute of Science and Technology, 3 | 1999-2000, All rights reserved, and is distributed as 4 | free software under the following license. 5 | 6 | Redistribution and use in source and binary forms, with or 7 | without modification, are permitted provided that the following 8 | conditions are met: 9 | 10 | - Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | - Redistributions in binary form must reproduce the above 14 | copyright notice, this list of conditions and the following 15 | disclaimer in the documentation and/or other materials provided 16 | with the distribution. 17 | 18 | - Neither name of the copyright holders nor the names of its 19 | contributors may be used to endorse or promote products derived 20 | from this software without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE 23 | CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 24 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 25 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 26 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE 27 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 28 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 29 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 30 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 31 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 32 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 33 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 34 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 35 | 36 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Data.Char (toLower) 3 | import System.Environment 4 | import System.IO 5 | import Syntax 6 | import qualified Lexer as L 7 | import qualified Parser as P 8 | import qualified Static as S 9 | import qualified Type as T 10 | import Compiler (programToExpr, expandCon, skiCompile) 11 | import PatComp (compilePatternMatch) 12 | import Optimizer (optimizeExpr) 13 | import Builtin (expandBltin) 14 | import PPrint (showProgram) 15 | 16 | compile s = (prog, as ++ a, expr2, ski2, ce') 17 | where (prog, is, ce', as) = S.analyze ce topdecls 18 | topdecls = P.Decl (P.VarDecl ("@main", [], P.Rhs (P.Var "main") [])) 19 | : (P.parse (L.lexer "argf" s)) 20 | as' = as ++ T.preludeAssumptions 21 | (a, prog') = T.tiProgram ce' as' prog 22 | prog2 = ([],[is]):prog' 23 | prog3 = compilePatternMatch prog2 24 | expr1 = expandCon $ programToExpr prog3 25 | expr2 = optimizeExpr expr1 26 | ski1 = skiCompile expr2 27 | ski2 = expandBltin ski1 28 | Just ce = T.addCoreClasses T.initialEnv 29 | 30 | main :: IO () 31 | main = do source <- argf 32 | let (p, as, p', e, ce) = compile source in 33 | do --hPutStrLn stderr (show p') 34 | --mapM_ (hPutStrLn stderr . show) as 35 | putStrLn $ insertNewline 80 $ map toLower $ show e 36 | 37 | insertNewline :: Int -> String -> String 38 | insertNewline n [] = [] 39 | insertNewline n s = let (line, s') = splitAt n s 40 | in (line ++ '\n' : insertNewline n s') 41 | 42 | argf :: IO String 43 | argf = do argv <- getArgs 44 | if argv == [] 45 | then getContents 46 | else do conts <- mapM getFileContents argv 47 | return (concat conts) 48 | 49 | getFileContents :: String -> IO String 50 | getFileContents fname = do handle <- openFile fname ReadMode 51 | hGetContents handle 52 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | SRC = Lexer.hs Parser.hs Syntax.hs PPrint.hs Static.hs SCC.hs \ 2 | Type.hs PatComp.hs Compiler.hs Optimizer.hs Builtin.hs Main.hs 3 | 4 | GHCFLAGS = 5 | OPTFLAGS = -O 6 | #PROFFLAGS = -prof -auto-all 7 | 8 | all: hs2lazy examples 9 | 10 | hs2lazy: $(SRC) 11 | ghc $(GHCFLAGS) $(OPTFLAGS) $(PROFFLAGS) -o $@ --make Main.hs 12 | 13 | Lexer.hs: Lexer.x 14 | alex Lexer.x 15 | 16 | clean: 17 | rm -f *.o *.hi hs2lazy hs2lazy.exe 18 | 19 | examples: hs2lazy 20 | make -C examples -------------------------------------------------------------------------------- /Optimizer.hs: -------------------------------------------------------------------------------- 1 | module Optimizer where 2 | import Syntax 3 | 4 | optimizeExpr :: Expr -> Expr 5 | optimizeExpr = optExpr 6 | 7 | optExpr :: Expr -> Expr 8 | optExpr e@(Var _) = e 9 | optExpr e@(Lit _) = e 10 | optExpr e@(Con _) = e 11 | optExpr (Ap e1 e2) = Ap (optExpr e1) (optExpr e2) 12 | optExpr (Let bg e) = optLet bg e 13 | optExpr (Lambda (vs, Rhs e)) = Lambda (vs, Rhs (optExpr e)) 14 | optExpr (ESign e sc) = optExpr e 15 | 16 | optBindGroup :: [Impl] -> BindGroup 17 | optBindGroup is = ([], [is']) 18 | where is' = [(i, [(vs, Rhs (optExpr e))]) | (i, [(vs, Rhs e)]) <- is] 19 | 20 | optLet :: BindGroup -> Expr -> Expr 21 | optLet bg e = case bindings bg of 22 | [(v, [([], Rhs e')])] | simple e' -> optExpr (substVar e' v e) 23 | is -> Let (optBindGroup is) (optExpr e) 24 | where simple (Var _) = True 25 | simple (Lit _) = True 26 | simple (Con _) = True 27 | simple _ = False 28 | 29 | substVar :: Expr -> Id -> Expr -> Expr 30 | substVar e' v e@(Var i) | i == v = e' 31 | | otherwise = e 32 | substVar e' v e@(Lit _) = e 33 | substVar e' v e@(Con _) = e 34 | substVar e' v (Ap e1 e2) = Ap (substVar e' v e1) (substVar e' v e2) 35 | substVar e' v (Let bg e) 36 | | v `elem` map fst (bindings bg) = Let bg e 37 | | otherwise = Let (subVarBindGroup e' v bg) (substVar e' v e) 38 | substVar e' v (Case e gds) = 39 | Case (substVar e' v e) [(p, if v `elem` patVars p 40 | then rhs else subVarRhs e' v rhs) 41 | | (p, rhs) <- gds] 42 | substVar e' v (Lambda alt) = Lambda (subVarAlt e' v alt) 43 | substVar e' v (ESign e sc) = ESign (substVar e' v e) sc 44 | 45 | subVarBindGroup :: Expr -> Id -> BindGroup -> BindGroup 46 | subVarBindGroup e' v (es, iss) = (es', iss') 47 | where es' = [(i, sc, subVarAlts e' v alts) | (i, sc, alts) <- es] 48 | iss' = map (\is -> [(i, subVarAlts e' v alts) | (i, alts) <- is]) iss 49 | 50 | subVarAlts :: Expr -> Id -> [Alt] -> [Alt] 51 | subVarAlts e' v = map (subVarAlt e' v) 52 | subVarAlt :: Expr -> Id -> Alt -> Alt 53 | subVarAlt e' v (ps, rhs) | any (elem v) (map patVars ps) = (ps, rhs) 54 | | otherwise = (ps, subVarRhs e' v rhs) 55 | 56 | subVarRhs :: Expr -> Id -> Rhs -> Rhs 57 | subVarRhs e' v (Rhs e) = Rhs (substVar e' v e) 58 | subVarRhs e' v (Guarded gds) = Guarded [(substVar e' v c, substVar e' v e) 59 | | (c, e) <- gds] 60 | subVarRhs e' v (Where bg rhs) 61 | | v `elem` map fst (bindings bg) = Where bg rhs 62 | | otherwise = Where (subVarBindGroup e' v bg) (subVarRhs e' v rhs) 63 | -------------------------------------------------------------------------------- /PPrint.hs: -------------------------------------------------------------------------------- 1 | module PPrint where 2 | import Syntax 3 | --import IOExts (trace) 4 | 5 | --traceProgram :: Program -> Program 6 | --traceProgram p = trace (showProgram p) p 7 | 8 | showProgram :: Program -> String 9 | showProgram p = join ";\n" (map ssBindGroup p) "" 10 | 11 | join :: String -> [ShowS] -> ShowS 12 | join _ [] = id 13 | join sep ss = foldr1 (\l r -> l . (sep++) . r) ss 14 | 15 | ssBindGroup :: BindGroup -> ShowS 16 | ssBindGroup (es, iss) = join ";\n" (showses ++ showsis) 17 | where showses = concatMap ssExpl es 18 | showsis = concatMap ssImpl (concat iss) 19 | ssExpl (i, sc, alts) = ssSig i sc : map (ssDef i) alts 20 | ssImpl (i, alts) = map (ssDef i) alts 21 | 22 | ssSig :: Id -> Scheme -> ShowS 23 | ssSig i sc = (i++) . (" :: "++) . shows sc 24 | 25 | ssDef :: Id -> Alt -> ShowS 26 | ssDef i (ps, rhs) = lhs . ssRhs " = " rhs 27 | where lhs = join " " ((i++) : map (showsPrec 1) ps) 28 | 29 | ssRhs :: String -> Rhs -> ShowS 30 | ssRhs sep (Rhs e) = (sep++) . showsPrec 0 e 31 | ssRhs sep (Guarded gds) = join "\n\t" gds' 32 | where gds' = [(" | "++) . showsPrec 0 cond . (sep++) . showsPrec 0 e 33 | | (cond, e) <- gds] 34 | ssRhs sep rhs@(Where _ _) = 35 | ssRhs sep rhs' . ("\n\twhere {"++) . ssBindGroup bg . ('}':) 36 | where (bg, rhs') = collectBg rhs 37 | 38 | collectBg :: Rhs -> (BindGroup, Rhs) 39 | collectBg (Where (es, iss) rhs) = ((es++es', iss++iss'), rhs') 40 | where ((es', iss'), rhs') = collectBg rhs 41 | collectBg rhs = (([],[]), rhs) 42 | 43 | instance Show Expr where 44 | showsPrec _ (Var i) = (i++) 45 | showsPrec _ (Lit l) = shows l 46 | showsPrec _ (Con con) = (conName con ++) 47 | showsPrec p (Ap e1 e2) = showParen (p > 2) $ 48 | showsPrec 2 e1 . (' ':) . showsPrec 3 e2 49 | showsPrec p (Let bg e) = showParen (p > 0) $ 50 | ("let {"++) . ssBindGroup bg . ("} in "++) . showsPrec 0 e 51 | showsPrec p (Case e pes) = showParen (p > 0) $ 52 | ("case "++) . showsPrec 0 e . (" of {"++) . (join ";\n\t" alts) . ('}':) 53 | where alts = [showsPrec 0 p . ssRhs " -> " rhs | (p, rhs) <- pes] 54 | showsPrec p (Lambda (ps, Rhs e)) = showParen (p > 0) $ 55 | ("\\"++) . join " " (map (showsPrec 1) ps) . ("-> "++) . showsPrec 0 e 56 | showsPrec p (ESign e sc) = showParen True $ 57 | showsPrec 0 e . (" :: "++) . shows sc 58 | showsPrec p (ClassPH pred) = ('<':) . shows pred . ('>':) 59 | showsPrec p (RecPH i) = ('<':) . (i++) . ('>':) 60 | 61 | instance Show Pat where 62 | showsPrec _ (PVar i) = (i++) 63 | showsPrec _ PWildcard = ('_':) 64 | showsPrec p (PAs i pat) = showParen (p > 1) $ 65 | (i++) . ('@':) . showsPrec 1 pat 66 | showsPrec _ (PLit l) = shows l 67 | showsPrec p (PCon con []) = (conName con ++) 68 | showsPrec p (PCon con ps) = showParen (p > 0) $ 69 | join " " ((conName con++) : map (showsPrec 1) ps) 70 | 71 | instance Show Rhs where 72 | showsPrec _ = ssRhs " -> " 73 | -------------------------------------------------------------------------------- /Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser where 2 | import Control.Monad (liftM) 3 | import Text.ParserCombinators.Parsec hiding (satisfy) 4 | import Text.ParserCombinators.Parsec.Expr 5 | import Lexer 6 | 7 | data TopDecl = Decl Decl 8 | | DataDecl (Context, String, [String], [Constr]) 9 | | TypeDecl (String, [String], Type) 10 | | ClassDecl (Context, String, Type, [Decl]) 11 | | InstDecl (Context, String, Type, [Decl]) 12 | | ImpDecl 13 | deriving Show 14 | 15 | type Constr = (String, [Type]) 16 | 17 | type Context = [(String, Type)] -- Eq a : [("Eq", TyVar "a")] 18 | 19 | data Decl = VarDecl (String, [Pat], Rhs) 20 | | PatBind (Pat, Rhs) 21 | | SigDecl ([String], Context, Type) 22 | deriving Show 23 | 24 | data Rhs = Rhs Expr [Decl] 25 | | Guarded [(Expr, Expr)] [Decl] 26 | deriving Show 27 | 28 | data Type = TyTuple [Type] 29 | | TyVar String 30 | | TyCon String 31 | | TyAp Type Type 32 | deriving Show 33 | 34 | data Expr = Var String 35 | | Con String 36 | | Tuple [Expr] 37 | | LitInt Int 38 | | LitChar String 39 | | LitStr String 40 | | Ap Expr Expr 41 | | Let [Decl] Expr 42 | | Lambda [Pat] Expr 43 | | ESign Expr Context Type 44 | | Case Expr [(Pat, Rhs)] 45 | deriving Show 46 | 47 | data Pat = PVar String 48 | | PCon String [Pat] 49 | | PTuple [Pat] 50 | | PInt Int 51 | | PChar String 52 | | PStr String 53 | | AsPat String Pat 54 | | Wildcard 55 | deriving Show 56 | 57 | data Fixity = InfixN Int | InfixL Int | InfixR Int deriving Eq 58 | 59 | type HsParser a = GenParser (Token, SourcePos) () a 60 | 61 | ----------------------------------------------------------------------------- 62 | -- declarations 63 | 64 | program :: HsParser [TopDecl] 65 | program = braceList topdecl 66 | 67 | topdecl :: HsParser TopDecl 68 | topdecl = datadecl <|> typedecl <|> classdecl <|> instdecl <|> liftM Decl decl <|> impdecl 69 | 70 | impdecl :: HsParser TopDecl 71 | impdecl = do tokenImport 72 | _ <- sepBy1 conid varsym 73 | skipMany tokenHiding 74 | skipMany (parenList var) 75 | return ImpDecl 76 | 77 | datadecl :: HsParser TopDecl 78 | datadecl = do tokenData 79 | (ctx, (c, vs)) <- context_simpletype 80 | tokenEq 81 | cs <- constrs 82 | return (DataDecl (ctx, c, vs, cs)) 83 | 84 | typedecl :: HsParser TopDecl 85 | typedecl = do tokenType 86 | (c, vs) <- simpletype 87 | tokenEq 88 | t <- type_ 89 | return (TypeDecl (c, vs, t)) 90 | 91 | classdecl :: HsParser TopDecl 92 | classdecl = do tokenClass 93 | (ctx, (id, t)) <- qualType scontext test 94 | decls <- whereList cdecl 95 | return (ClassDecl (ctx, id, t, decls)) 96 | where test (TyAp (TyCon id) t@(TyVar _)) = return (id, t) 97 | test x = unexpected (show x) 98 | 99 | instdecl :: HsParser TopDecl 100 | instdecl = do tokenInstance 101 | (ctx, (id, t)) <- qualType scontext pred 102 | decls <- whereList idecl 103 | return (InstDecl (ctx, id, t, decls)) 104 | where pred (TyAp (TyCon id) t) = do { t' <- test inst t; return (id, t) } 105 | pred t = unexpected (show t) 106 | inst (TyCon _) = True 107 | inst (TyAp t (TyVar _)) = inst t 108 | inst (TyTuple []) = True 109 | inst (TyTuple (TyVar _ : ts)) = inst (TyTuple ts) 110 | 111 | decls :: HsParser [Decl] 112 | decls = braceList decl 113 | 114 | decl :: HsParser Decl 115 | decl = gendecl 116 | <|> do (id, pats) <- try funlhs 117 | r <- rhs 118 | return (VarDecl (id, pats, r)) 119 | <|> do pat <- opPat 120 | r <- rhs 121 | return (PatBind (pat, r)) 122 | 123 | cdecl :: HsParser Decl 124 | cdecl = gendecl <|> idecl 125 | 126 | idecl :: HsParser Decl 127 | idecl = do (id, pats) <- funlhs 128 | r <- rhs 129 | return (VarDecl (id, pats, r)) 130 | 131 | gendecl :: HsParser Decl 132 | gendecl = do vs <- try varsCoco 133 | (ctx, t) <- context_type 134 | return (SigDecl (vs, ctx, t)) 135 | -- <|> fixity 136 | 137 | whereList :: HsParser a -> HsParser [a] 138 | whereList p = option [] (do { tokenWhere; braceList p }) 139 | 140 | varsCoco :: HsParser [String] 141 | varsCoco = do { vs <- vars; tokenCoco; return vs } 142 | 143 | rhs :: HsParser Rhs 144 | rhs = do tokenEq 145 | e <- expr 146 | ds <- whereDecls 147 | return (Rhs e ds) 148 | <|> do gds <- many1 (guard tokenEq) 149 | ds <- whereDecls 150 | return (Guarded gds ds) 151 | 152 | constrs :: HsParser [Constr] 153 | constrs = sepBy1 constr tokenBar 154 | 155 | constr :: HsParser Constr 156 | constr = do id <- con 157 | ts <- many atype 158 | return (id, ts) 159 | -- <|> infix conop <|> fielddecl 160 | 161 | ----------------------------------------------------------------------------- 162 | -- types 163 | 164 | context_type :: HsParser (Context, Type) 165 | context_type = qualType context return 166 | 167 | context_simpletype :: HsParser (Context, (String, [String])) 168 | context_simpletype = qualType context toSimpletype 169 | 170 | qualType :: (Type -> HsParser Context) -> (Type -> HsParser a) 171 | -> HsParser (Context, a) 172 | qualType toContext toType = 173 | do t1 <- type_ 174 | do tokenImply 175 | ctx <- toContext t1 176 | t2 <- type_ 177 | t <- toType t2 178 | return (ctx, t) 179 | <|> do { t <- toType t1; return ([], t) } 180 | 181 | 182 | context :: Type -> HsParser Context 183 | context (TyTuple ts) = mapM class_ ts 184 | context t = mapM class_ [t] 185 | 186 | scontext :: Type -> HsParser Context 187 | scontext (TyTuple ts) = mapM simpleclass ts 188 | scontext t = mapM simpleclass [t] 189 | 190 | class_ :: Type -> HsParser (String, Type) 191 | class_ (TyAp (TyCon cls) t) = if test t then return (cls, t) 192 | else unexpected (show t) 193 | where test (TyVar _) = True 194 | test (TyAp l _) = test l 195 | test _ = False 196 | class_ t = unexpected (show t) 197 | 198 | simpleclass :: Type -> HsParser (String, Type) 199 | simpleclass (TyAp (TyCon cls) t@(TyVar var)) = return (cls, t) 200 | simpleclass t = unexpected (show t) 201 | 202 | toSimpletype :: Type -> HsParser (String, [String]) 203 | toSimpletype (TyCon con) = return (con, []) 204 | toSimpletype (TyAp l (TyVar v)) = do (c, vs) <- toSimpletype l 205 | return (c, vs++[v]) 206 | toSimpletype t = unexpected (show t) 207 | 208 | simpletype :: HsParser (String, [String]) 209 | simpletype = do c <- conid 210 | vs <- many varid 211 | return (c, vs) 212 | 213 | type_ :: HsParser Type 214 | type_ = chainr1 btype ap 215 | where ap = do { tokenRArrow; return arrow } 216 | 217 | btype :: HsParser Type 218 | btype = chainl1 atype (return TyAp) 219 | 220 | atype :: HsParser Type 221 | atype = do { t <- brackets type_; return (TyAp (TyCon "[]") t) } 222 | <|> do ts <- parenList type_ 223 | case ts of 224 | [t] -> return t 225 | _ -> return (TyTuple ts) 226 | <|> qtycon 227 | <|> tyvar 228 | 229 | qtycon :: HsParser Type 230 | qtycon = do { i <- conid; return (TyCon i) } 231 | 232 | tyvar :: HsParser Type 233 | tyvar = do { i <- varid; return (TyVar i) } 234 | 235 | ----------------------------------------------------------------------------- 236 | -- expressions 237 | 238 | expr :: HsParser Expr 239 | expr = do e <- opExp 240 | option e $ do tokenCoco 241 | (ctx, t) <- context_type 242 | return (ESign e ctx t) 243 | 244 | opExp :: HsParser Expr 245 | opExp = buildExpressionParser (opTable qop) exp10 246 | 247 | opTable op = [[Infix (op (InfixN n)) AssocNone, 248 | Infix (op (InfixL n)) AssocLeft, 249 | Infix (op (InfixR n)) AssocRight] | n <- reverse [0..9]] 250 | 251 | qop :: Fixity -> HsParser (Expr -> Expr -> Expr) 252 | qop f = qvarop f <|> qconop f 253 | 254 | qvarop :: Fixity -> HsParser (Expr -> Expr -> Expr) 255 | qvarop f = do { op <- varsymF f; return (ap2 (Var op)) } 256 | 257 | qconop :: Fixity -> HsParser (Expr -> Expr -> Expr) 258 | qconop f = do { op <- consymF f; return (ap2 (Con op)) } 259 | 260 | exp10 :: HsParser Expr 261 | exp10 = do tokenLambda 262 | ps <- many1 apat 263 | tokenRArrow 264 | e <- expr 265 | return (Lambda ps e) 266 | <|> do { tokenLet; ds <- decls; tokenIn; e <- expr; return (Let ds e) } 267 | <|> do tokenIf; e1 <- expr 268 | tokenThen; e2 <- expr 269 | tokenElse; e3 <- expr 270 | return (bltinApp "IF" [e1, e2, e3]) 271 | <|> do { tokenCase; e <- expr; tokenOf; a <- alts; return (Case e a) } 272 | <|> do { tokenDo; fail "not implemented" } 273 | <|> fexp 274 | 275 | fexp :: HsParser Expr 276 | fexp = chainl1 aexp (return Ap) 277 | 278 | aexp :: HsParser Expr 279 | aexp = do { i <- qvar; return (Var i) } 280 | <|> do { c <- gcon; return (Con c) } 281 | <|> do { i <- litInt; return (LitInt i) } 282 | <|> do { c <- litChar; return (LitChar c) } 283 | <|> do { s <- litStr; return (LitStr s) } 284 | <|> do es <- parenList expr 285 | if length es == 1 then return (head es) else return (Tuple es) 286 | <|> do es <- bracketList expr 287 | return (foldr cons (Con "[]") es) 288 | -- まだいろいろ足りない 289 | 290 | alts :: HsParser [(Pat, Rhs)] 291 | alts = braceList alt 292 | 293 | alt :: HsParser (Pat, Rhs) 294 | alt = do{ p <- pat 295 | ; do tokenRArrow 296 | e <- expr 297 | ds <- whereDecls 298 | return (p, Rhs e ds) 299 | <|> do gds <- many1 (guard tokenRArrow) 300 | ds <- whereDecls 301 | return (p, Guarded gds ds) 302 | } 303 | 304 | whereDecls :: HsParser [Decl] 305 | whereDecls = option [] (do { tokenWhere; decls }) 306 | 307 | guard :: HsParser Token -> HsParser (Expr, Expr) 308 | guard sep = do tokenBar 309 | gd <- opExp 310 | sep 311 | e <- expr 312 | return (gd, e) 313 | 314 | ----------------------------------------------------------------------------- 315 | -- patterns 316 | 317 | funlhs :: HsParser (String, [Pat]) 318 | funlhs = do v <- var 319 | ps <- many apat 320 | return (v, ps) 321 | 322 | pat :: HsParser Pat 323 | pat = opPat 324 | 325 | opPat :: HsParser Pat 326 | opPat = buildExpressionParser (opTable qconopPat) pat10 327 | 328 | qconopPat :: Fixity -> HsParser (Pat -> Pat -> Pat) 329 | qconopPat f = do { op <- consymF f; return (\l r -> PCon op [l, r]) } 330 | 331 | pat10 :: HsParser Pat 332 | pat10 = do c <- gcon 333 | ps <- many apat 334 | return (PCon c ps) 335 | <|> apat 336 | 337 | apat :: HsParser Pat 338 | apat = do v <- var 339 | option (PVar v) (do { tokenAt; p <- apat; return (AsPat v p) }) 340 | <|> do { c <- gcon; return (PCon c []) } 341 | <|> do { i <- litInt; return (PInt i) } 342 | <|> do { c <- litChar; return (PChar c) } 343 | <|> do { s <- litStr; return (PStr s) } 344 | <|> do { tokenWildcard; return Wildcard } 345 | <|> do ps <- parenList pat 346 | if length ps == 1 then return (head ps) else return (PTuple ps) 347 | <|> do ps <- bracketList pat 348 | return (foldr pcons (PCon "[]" []) ps) 349 | -- <|> ... 350 | 351 | 352 | ----------------------------------------------------------------------------- 353 | -- primitive constructs 354 | 355 | gcon :: HsParser String 356 | gcon = qcon 357 | 358 | qcon :: HsParser String 359 | qcon = con 360 | 361 | con :: HsParser String 362 | con = try (parens consym) <|> conid 363 | 364 | qconid :: HsParser String 365 | qconid = conid 366 | 367 | conid :: HsParser String 368 | conid = token' test 369 | where test (TokenConId id) = Just id 370 | test _ = Nothing 371 | 372 | consym :: HsParser String 373 | consym = token' test 374 | where test (TokenConOp id) = Just id 375 | test _ = Nothing 376 | 377 | consymF :: Fixity -> HsParser String 378 | consymF f = token' test 379 | where test (TokenConOp id) | fixity id == f = Just id 380 | test _ = Nothing 381 | 382 | vars :: HsParser [String] 383 | vars = sepBy1 var tokenComma 384 | 385 | qvar :: HsParser String 386 | qvar = var 387 | 388 | var :: HsParser String 389 | var = try (parens varsym) <|> varid 390 | 391 | varid :: HsParser String 392 | varid = token' test 393 | where test (TokenId id) = Just id 394 | test _ = Nothing 395 | 396 | varsym :: HsParser String 397 | varsym = token' test 398 | where test (TokenOp id) = Just id 399 | test _ = Nothing 400 | 401 | varsymF :: Fixity -> HsParser String 402 | varsymF f = token' test 403 | where test (TokenOp id) | fixity id == f = Just id 404 | test _ = Nothing 405 | 406 | -- fixity and precedence are now hardcoded 407 | fixity :: String -> Fixity 408 | fixity "." = InfixR 9 409 | fixity "!!" = InfixL 9 410 | fixity "^" = InfixR 8 411 | fixity "^^" = InfixR 8 412 | fixity "**" = InfixR 8 413 | fixity "*" = InfixL 7 414 | fixity "/" = InfixL 7 415 | fixity "+" = InfixL 6 416 | fixity "-" = InfixL 6 417 | fixity ":" = InfixR 5 418 | fixity "++" = InfixR 5 419 | fixity "==" = InfixN 4 420 | fixity "/=" = InfixN 4 421 | fixity "<" = InfixN 4 422 | fixity "<=" = InfixN 4 423 | fixity ">=" = InfixN 4 424 | fixity ">" = InfixN 4 425 | fixity "&&" = InfixR 3 426 | fixity "||" = InfixR 2 427 | fixity ">>" = InfixL 1 428 | fixity ">>="= InfixL 1 429 | fixity "=<<"= InfixR 1 430 | fixity "$" = InfixR 0 431 | fixity "$!" = InfixR 0 432 | fixity _ = InfixL 9 433 | 434 | litInt :: HsParser Int 435 | litInt = token' test 436 | where test (TokenInt i) = Just i 437 | test _ = Nothing 438 | 439 | litChar :: HsParser String 440 | litChar = token' test 441 | where test (TokenChar i) = Just i 442 | test _ = Nothing 443 | 444 | litStr :: HsParser String 445 | litStr = token' test 446 | where test (TokenStr i) = Just i 447 | test _ = Nothing 448 | 449 | tokenIf = hsToken TokenIf 450 | tokenThen = hsToken TokenThen 451 | tokenElse = hsToken TokenElse 452 | tokenLet = hsToken TokenLet 453 | tokenIn = hsToken TokenIn 454 | tokenCase = hsToken TokenCase 455 | tokenOf = hsToken TokenOf 456 | tokenDo = hsToken TokenDo 457 | tokenData = hsToken TokenData 458 | tokenType = hsToken TokenType 459 | tokenClass = hsToken TokenClass 460 | tokenInstance = hsToken TokenInstance 461 | tokenWhere = hsToken TokenWhere 462 | tokenImport = hsToken TokenImport 463 | tokenHiding = hsToken TokenHiding 464 | 465 | tokenDotDot = hsToken TokenDotDot 466 | tokenCoco = hsToken TokenCoco 467 | tokenEq = hsToken TokenEq 468 | tokenLambda = hsToken TokenLambda 469 | tokenBar = hsToken TokenBar 470 | tokenLArrow = hsToken TokenLArrow 471 | tokenRArrow = hsToken TokenRArrow 472 | tokenAt = hsToken TokenAt 473 | tokenTilde = hsToken TokenTilde 474 | tokenImply = hsToken TokenImply 475 | 476 | tokenLParen = hsToken TokenLParen 477 | tokenRParen = hsToken TokenRParen 478 | tokenLBrace = hsToken TokenLBrace 479 | tokenRBrace = hsToken TokenRBrace 480 | tokenLBracket = hsToken TokenLBracket 481 | tokenRBracket = hsToken TokenRBracket 482 | tokenComma = hsToken TokenComma 483 | tokenSemicolon = hsToken TokenSemicolon 484 | tokenWildcard = hsToken TokenWildcard 485 | 486 | ----------------------------------------------------------------------------- 487 | -- utilities 488 | 489 | token' :: (Token -> Maybe a) -> HsParser a 490 | token' test = token showToken posToken testToken 491 | where showToken (tok, pos) = show tok 492 | posToken (tok, pos) = pos 493 | testToken (tok, pos) = test tok 494 | 495 | satisfy :: (Token -> Bool) -> HsParser Token 496 | satisfy test = token' (\t -> if test t then Just t else Nothing) 497 | 498 | hsToken :: Token -> HsParser Token 499 | hsToken tok = satisfy (== tok) 500 | 501 | parens :: HsParser a -> HsParser a 502 | parens = hsBetween tokenLParen tokenRParen 503 | 504 | brackets :: HsParser a -> HsParser a 505 | brackets = hsBetween tokenLBracket tokenRBracket 506 | 507 | parenList :: HsParser a -> HsParser [a] 508 | parenList p = hsBetween tokenLParen tokenRParen (sepBy p tokenComma) 509 | 510 | braceList :: HsParser a -> HsParser [a] 511 | braceList p = hsBetween tokenLBrace tokenRBrace (sepBy p tokenSemicolon) 512 | 513 | bracketList :: HsParser a -> HsParser [a] 514 | bracketList p = hsBetween tokenLBracket tokenRBracket (sepBy p tokenComma) 515 | 516 | hsBetween :: HsParser Token -> HsParser Token -> HsParser a -> HsParser a 517 | hsBetween open close = between open close 518 | 519 | test :: Show a => (a -> Bool) -> a -> HsParser a 520 | test f a = if f a then return a else unexpected (show a) 521 | 522 | ----------------------------------------------------------------------------- 523 | -- expression constructors 524 | 525 | arrow :: Type -> Type -> Type 526 | arrow l r = TyAp (TyAp (TyCon "(->)") l) r 527 | 528 | ap2 :: Expr -> Expr -> Expr -> Expr 529 | ap2 op l r = Ap (Ap op l) r 530 | 531 | bltinApp :: String -> [Expr] -> Expr 532 | bltinApp i es = foldl Ap (Var i) es 533 | 534 | cons :: Expr -> Expr -> Expr 535 | cons e1 e2 = (Con ":") `Ap` e1 `Ap` e2 536 | 537 | pcons :: Pat -> Pat -> Pat 538 | pcons p1 p2 = PCon ":" [p1, p2] 539 | 540 | ----------------------------------------------------------------------------- 541 | -- runner 542 | 543 | parse :: [(Token, SourcePos)] -> [TopDecl] 544 | parse input = case runParser program () "stdin" input of 545 | Left err -> error ("parse error at " ++ show err) 546 | Right tds -> tds 547 | 548 | ----------------------------------------------------------------------------- 549 | -- test 550 | {- 551 | main = do source <- argf 552 | parseTest program (lexer "argf" source) 553 | 554 | argf :: IO String 555 | argf = do argv <- getArgs 556 | if argv == [] 557 | then getContents 558 | else do conts <- mapM getFileContents argv 559 | return (concat conts) 560 | 561 | getFileContents :: String -> IO String 562 | getFileContents fname = do handle <- IO.openFile fname IO.ReadMode 563 | IO.hGetContents handle 564 | -} 565 | -------------------------------------------------------------------------------- /PatComp.hs: -------------------------------------------------------------------------------- 1 | module PatComp (compilePatternMatch, patBindings) where 2 | import Data.List 3 | import Control.Monad hiding (ap) 4 | import Control.Monad.State hiding (ap) 5 | import Syntax 6 | import PPrint () 7 | 8 | type PatComp = State Int 9 | 10 | compilePatternMatch :: Program -> Program 11 | compilePatternMatch pgm = evalState (pcProgram pgm) 0 12 | 13 | pcProgram :: Program -> PatComp Program 14 | pcProgram = mapM pcBindGroup 15 | 16 | pcBindGroup :: BindGroup -> PatComp BindGroup 17 | pcBindGroup (es, iss) = 18 | do es' <- mapM pcExpl es 19 | iss' <- mapM (mapM pcImpl) iss 20 | return (es', iss') 21 | 22 | pcExpl :: Expl -> PatComp Expl 23 | pcExpl (i, sc, alts) = do { alt <- pcAlts alts; return (i, sc, [alt]) } 24 | 25 | pcImpl :: Impl -> PatComp Impl 26 | pcImpl (i, alts) = do { alt <- pcAlts alts; return (i, [alt]) } 27 | 28 | pcAlts :: [Alt] -> PatComp Alt 29 | pcAlts [(ps, Rhs e)] 30 | | all isPVar ps = do { e' <- pcExpr e; return (ps, Rhs e') } 31 | where isPVar (PVar _) = True 32 | isPVar _ = False 33 | pcAlts qs = do us <- newVars n 34 | rhs <- match us qs matchError 35 | return (map PVar us, Rhs rhs) 36 | where n = length $ fst $ head $ qs 37 | 38 | pcRhs :: Rhs -> Expr -> PatComp Expr 39 | pcRhs (Rhs e) _ = pcExpr e 40 | pcRhs (Where bg rhs) def = liftM (Let bg) (pcRhs rhs def) 41 | pcRhs (Guarded gds) def = do gds' <- mapM pcGuard gds 42 | return $ foldr makeIf def gds' 43 | 44 | pcGuard :: (Expr, Expr) -> PatComp (Expr, Expr) 45 | pcGuard (e1, e2) = do e1' <- pcExpr e1 46 | e2' <- pcExpr e2 47 | return (e1', e2') 48 | 49 | pcExpr :: Expr -> PatComp Expr 50 | pcExpr (Ap e1 e2) = do e1' <- pcExpr e1 51 | e2' <- pcExpr e2 52 | return (Ap e1' e2') 53 | pcExpr (Let bg e) = do bg' <- pcBindGroup bg 54 | e' <- pcExpr e 55 | return (Let bg' e') 56 | pcExpr (Lambda a) = liftM Lambda (pcAlts [a]) 57 | pcExpr c@(Case e pes) = 58 | do e' <- pcExpr e 59 | case e' of 60 | (Var v) -> match [v] qs matchError 61 | e'' -> do v <- newVar 62 | m <- match [v] qs matchError 63 | return $ Let (bind1 v e'') m 64 | where qs = [([p], rhs) | (p, rhs) <- pes] 65 | pcExpr (ESign e sc) = do { e' <- pcExpr e; return $ ESign e' sc } 66 | pcExpr c = return c 67 | 68 | matchError :: Expr 69 | matchError = Ap (Var "error") (Lit $ LitStr $ "Non-exhaustive patterns") 70 | 71 | patBindings :: Expr -> Pat -> [Impl] 72 | patBindings v (PVar i) = [(i, [([], Rhs v)])] 73 | patBindings _ PWildcard = [] 74 | patBindings v (PAs i p) = (i, [([], Rhs v)]) : patBindings v p 75 | patBindings v (PLit _) = [] 76 | patBindings v (PCon con pats) 77 | = concat [patBindings (makeSel con n v) p | (p, n) <- zip pats [1..]] 78 | 79 | makeSel :: Const -> Int -> Expr -> Expr 80 | --makeSel con i e = ap (Var "SEL") [Lit (LitInt i), e] 81 | makeSel con i e = expr 82 | where vs = ["@@"++show v | v <- [1..(conArity con)]] 83 | body = Rhs $ Var $ vs !! (i-1) 84 | receiver = Lambda ([PVar v | v <- vs], body) 85 | expr = ap e [if i == conTag con then receiver else eError 86 | | i <- [1..(tyconNumCon $ conTycon con)]] 87 | eError = Ap (Var "error") (Lit $ LitStr $ "!?") 88 | 89 | type Equation = Alt 90 | 91 | isVar :: Equation -> Bool 92 | isVar (p:_, _) = test p 93 | where test (PVar _) = True 94 | test PWildcard = True 95 | test (PAs _ p) = test p 96 | test (PLit _) = False 97 | test (PCon _ _) = False 98 | 99 | partitionEqns :: Eq b => (a -> b) -> [a] -> [[a]] 100 | partitionEqns f [] = [] 101 | partitionEqns f [x] = [[x]] 102 | partitionEqns f (x:xs@(x':_)) | f x == f x' = tack x (partitionEqns f xs) 103 | | otherwise = [x] : partitionEqns f xs 104 | tack x xss = (x : head xss) : tail xss 105 | 106 | match :: [Id] -> [Equation] -> Expr -> PatComp Expr 107 | match [] qs def = foldrM pcRhs def (map snd qs) 108 | match us qs def = 109 | foldrM (matchVarCon us) def (partitionEqns isVar qs) 110 | 111 | matchVarCon :: [Id] -> [Equation] -> Expr -> PatComp Expr 112 | matchVarCon us@(u:_) qs def = 113 | case head $ fst $ head qs' of 114 | PLit _ -> bindDefault (matchLit us qs') def 115 | PCon _ _ -> bindDefault (matchCon us qs') def 116 | _ -> matchVar us qs' def 117 | where qs' = map sub qs 118 | sub (PAs v p : ps, rhs) = sub (p:ps, Where (bind1 v (Var u)) rhs) 119 | sub (ps, rhs) = (ps, rhs) 120 | 121 | matchVar :: [Id] -> [Equation] -> Expr -> PatComp Expr 122 | matchVar (u:us) qs def = match us (map sub qs) def 123 | where sub (PVar v : ps, rhs) = (ps, Where (bind1 v (Var u)) rhs) 124 | sub (PWildcard : ps, rhs) = (ps, rhs) 125 | 126 | bindDefault :: (Expr -> PatComp Expr) -> Expr -> PatComp Expr 127 | bindDefault f def 128 | | simple def = f def 129 | | otherwise = do v <- newVar 130 | e <- f (Var v) 131 | return $ Let (bind1 v def) e 132 | where simple _ = True 133 | {- これでは効率悪い -- 式のサイズで分けるとか? 134 | where simple (Var _) = True 135 | simple (Lit _) = True 136 | simple (Con _) = True 137 | simple _ = False 138 | -} 139 | 140 | matchLit :: [Id] -> [Equation] -> Expr -> PatComp Expr 141 | matchLit us qs def = 142 | do clauses <- mapM (matchLitClause us def) (groupLit qs) 143 | return $ foldr makeIf def clauses 144 | 145 | matchLitClause :: [Id] -> Expr -> (Literal, [Equation]) -> PatComp (Expr, Expr) 146 | matchLitClause (u:us) def (lit, qs) = 147 | do e <- match us [(ps,rhs) | (_:ps,rhs)<-qs] def 148 | return (ap (Var "&eq") [Var u, Lit lit], e) 149 | 150 | groupLit :: [Equation] -> [(Literal, [Equation])] 151 | groupLit [] = [] 152 | groupLit qs@((PLit l:_,_):_) = (l, qs') : groupLit qs'' 153 | where (qs', qs'') = partition (\(PLit l':_,_) -> l == l') qs 154 | 155 | matchCon :: [Id] -> [Equation] -> Expr -> PatComp Expr 156 | matchCon us qs def 157 | | isCovered grps = 158 | do clauses <- mapM (matchConClause us def) (init grps) 159 | lastClause <- matchConLastClause us def (last grps) 160 | return $ foldr makeIf lastClause clauses 161 | | otherwise = 162 | do clauses <- mapM (matchConClause us def) grps 163 | return $ foldr makeIf def clauses 164 | where grps = groupCon qs 165 | 166 | {- matchConClause [a,b] def ((:), [([: x xs, y], rhs)]) 167 | => (TAGEQ (:) a, let v1 = SEL 1 a, v2 = SEL 2 a in 168 | (match [v1,v2,b] [([x,xs,y],rhs)] def) 169 | => (TAGEQ (:) a, a (\v1 v2 -> (match [v1,v2,b] [([x,xs,y],rhs)] def)) error) 170 | -} 171 | matchConClause :: [Id] -> Expr -> (Const, [Equation]) -> PatComp (Expr, Expr) 172 | matchConClause (u:us) def (con, qs) = 173 | do us' <- newVars k' 174 | body <- match (us'++us) 175 | [(ps'++ps, rhs) | (PCon c ps':ps, rhs) <- qs] def 176 | let receiver = Lambda ([PVar v | v <- us'], Rhs body) 177 | expr = ap (Var u) [if i == conTag con then receiver else eError 178 | | i <- [1..(tyconNumCon $ conTycon con)]] 179 | in return (cond, expr) 180 | where cond = makeTagEq con (Var u) 181 | k' = conArity con 182 | eError = Ap (Var "error") (Lit $ LitStr $ "!?") 183 | 184 | matchConLastClause :: [Id] -> Expr -> (Const, [Equation]) -> PatComp Expr 185 | matchConLastClause us def grp = do (_, e) <- matchConClause us def grp 186 | return e 187 | 188 | groupCon :: [Equation] -> [(Const, [Equation])] 189 | groupCon [] = [] 190 | groupCon qs@((PCon c _:_,_):_) = (c, qs') : groupCon qs'' 191 | where (qs', qs'') = partition (\(PCon c' _:_,_) -> c == c') qs 192 | 193 | isCovered :: [(Const, [Equation])] -> Bool 194 | isCovered grps = n == 0 || length grps == n 195 | where n = tyconNumCon $ conTycon $ fst $ head grps 196 | 197 | newVars :: Int -> PatComp [Id] 198 | newVars k = do n <- get 199 | put (n+k) 200 | return ['@':show (n+i) | i <- [1..k]] 201 | 202 | newVar :: PatComp Id 203 | newVar = do n <- get 204 | put (n+1) 205 | return $ '@':show (n+1) 206 | 207 | makeIf :: (Expr, Expr) -> Expr -> Expr 208 | makeIf (c, e) e' = ap (Var "IF") [c, e, e'] 209 | 210 | {- makeTagEq (:) e => e (\x -> \xs -> True) False 211 | -} 212 | makeTagEq :: Const -> Expr -> Expr 213 | --makeTagEq con e = ap (Var "TAGEQ") [Con con, e] 214 | makeTagEq con e = ap e es 215 | where arities = tyconArities (conTycon con) 216 | es = [test a (b == conTag con) | (a, b) <- zip arities [1..]] 217 | test arity b = 218 | Lambda ([PVar ('_':show n) | n <- [1..arity]], 219 | Rhs $ if b then eTrue else eFalse) 220 | 221 | bind1 :: Id -> Expr -> BindGroup 222 | bind1 v e = ([], [[(v, [([], Rhs e)])]]) 223 | 224 | foldrM :: Monad m => (b -> a -> m a) -> a -> [b] -> m a 225 | foldrM f a xs = foldM (flip f) a (reverse xs) 226 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | hs2lazy -- Haskell to Lazy K compiler 2 | ===================================== 3 | 4 | ## What is this? 5 | 6 | This is a translator from a subset of Haskell to [Lazy K](http://homepages.cwi.nl/~tromp/cl/lazy-k.html). 7 | 8 | ## How to compile 9 | 10 | You can build hs2lazy with GHC by following command: 11 | 12 | ghc -o hs2lazy --make Main.hs 13 | 14 | ## How to use 15 | 16 | hs2lazy [source files] 17 | 18 | If multiple source files are given, they are concatenated in the order specified. Output Lazy K code is written to standard output. 19 | Prelude module is not automatically loaded. So, you may specify examples/hs2lazy-prelude.hs first, like following: 20 | 21 | hs2lazy examples/hs2lazy-prelude.hs foo.hs >foo.lazy 22 | 23 | ## How to write source code 24 | 25 | In Lazy K, input and output streams are represented as infinite lists of numbers (256 represents EOF). Hs2lazy programs handle I/O in similar way. 26 | 27 | In Haskell, type of `main` function is `IO ()`. But in hs2lazy, that is: 28 | 29 | main :: Stream -> Stream 30 | 31 | The Stream type is defined in hs2lazy-prelude.hs as 32 | 33 | data Stream = Stream Char Stream 34 | 35 | The input is a infinite stream of characters. For example: 36 | 37 | Stream 'f' $ Stream 'o' $ Stream 'o' $ Stream eof $ Stream eof ... 38 | 39 | `eof` is defined as `(chr 256)`. 40 | 41 | Streams can be converted to/from strings by `fromStream` and `toStream` defined in hs2lazy-prelude.hs. For example, following program reverses the input character-by-character. 42 | 43 | main = toStream . reverse . fromStream 44 | 45 | Or simply, 46 | 47 | main = interact reverse 48 | 49 | `interact` converts a String-to-String function to a Stream-to-Stream function. 50 | 51 | ## License 52 | 53 | Type.hs is based on [Typing Haskell in Haskell](http://web.cecs.pdx.edu/~mpj/thih/). See Lisence.thih for the license of it. 54 | -------------------------------------------------------------------------------- /SCC.hs: -------------------------------------------------------------------------------- 1 | module SCC (scc) where 2 | import Data.List (elemIndex) 3 | import Control.Monad (when) 4 | import Data.Array 5 | 6 | data SM s a = SM (s -> (a, s)) 7 | 8 | instance Monad (SM s) where 9 | SM c1 >>= fc2 = SM (\s0 -> let (r,s1) = c1 s0; SM c2 = fc2 r in c2 s1) 10 | return k = SM (\s -> (k,s)) 11 | 12 | readSM :: (s -> a) -> SM s a 13 | readSM f = SM (\s -> (f s, s)) 14 | 15 | updateSM :: (s -> s) -> SM s () 16 | updateSM f = SM (\s -> ((), f s)) 17 | 18 | changeSM :: (s -> (a, s)) -> SM s a 19 | changeSM f = SM (\s -> f s) 20 | 21 | runSM :: s -> SM s a -> (a,s) 22 | runSM s0 (SM c) = c s0 23 | 24 | type SCC i a = SM (Int, Array i Int, [i], [[i]]) a 25 | 26 | newId :: SCC i Int 27 | newId = changeSM (\(i,m,s,r) -> (i+1, (i+1,m,s,r))) 28 | 29 | setId :: Ix i => i -> Int -> SCC i () 30 | setId v i = updateSM (\(i',m,s,r) -> (i', m // [(v, i)], s, r)) 31 | 32 | idof :: Ix i => i -> SCC i Int 33 | idof v = readSM (\(i,m,s,r) -> m!v) 34 | 35 | push :: i -> SCC i () 36 | push v = updateSM (\(i,m,s,r) -> (i,m,v:s,r)) 37 | 38 | putComponents :: Ix i => i -> SCC i () 39 | putComponents v = updateSM $ \(i,m,s,r) -> 40 | let (c, _:s') = break (== v) s 41 | r' = (v:c) : r 42 | m' = m // [(u, rangeSize (bounds m)) | u <- (v:c)] 43 | in (i,m',s',r') 44 | 45 | adjId :: Ix i => Array i [i] -> i -> SCC i Int 46 | adjId adj v = do i <- idof v 47 | case i of 0 -> visit adj v 48 | n -> return n 49 | 50 | visit :: Ix i => Array i [i] -> i -> SCC i Int 51 | visit adj v = do nodeId <- newId 52 | setId v nodeId 53 | push v 54 | ids <- mapM (adjId adj) (adj!v) 55 | let minId = foldl min nodeId ids 56 | when (nodeId == minId) (putComponents v) 57 | return minId 58 | 59 | scc :: Eq a => [(a, [a])] -> [[a]] 60 | scc adj = map (map (vs !!)) (scc' adj') 61 | where adj' = array (0, length adj - 1) (map toIndex adj) 62 | toIndex (v, adjs) = (index v, map index adjs) 63 | vs = map fst adj 64 | index v = case elemIndex v vs of 65 | Just i -> i 66 | Nothing -> error "Illegal adjacency list" 67 | 68 | scc' :: Ix i => Array i [i] -> [[i]] 69 | scc' adj = r 70 | where (_, (_,_,_,r)) = runSM (0, idMap, [], []) sm 71 | idMap = array (bounds adj) [(i, 0) | i <- range (bounds adj)] 72 | sm = mapM (adjId adj) (range (bounds adj)) 73 | 74 | {- 75 | adj = [('a', "fbg"), ('b', ""), ('c', "a"), ('d', "f"), 76 | ('e', "d"), ('f', "e"), ('g', "cej"), ('h', "gi"), 77 | ('i', "h"), ('j', "kml"), ('k', ""), ('l', "gm"), ('m', "l")] 78 | result = ["hi","almjcg","k","b","fde"] 79 | 80 | test = scc' (array ('a','m') adj) == result 81 | test2 = scc adj == result 82 | -} 83 | -------------------------------------------------------------------------------- /Static.hs: -------------------------------------------------------------------------------- 1 | module Static where 2 | import Data.List(union, partition, (\\)) 3 | import qualified Data.List(find) 4 | import Syntax 5 | import qualified Parser as P 6 | import qualified Type as T 7 | import PatComp (patBindings) 8 | 9 | type TyconEnv = ([Tycon], [Synonym]) 10 | type DataType = (TyconEnv, [Const]) 11 | 12 | analyze :: ClassEnv -> [P.TopDecl] -> (Program, [Impl], ClassEnv, [Assump]) 13 | analyze ce tds = (prog, impls ce', ce', assumps ce') 14 | where (dataDecls, typeDecls, classDecls, instDecls, 15 | varDecls, patBinds, sigDecls) 16 | = splitDecls tds 17 | dt = anDataDecls synonyms dataDecls 18 | synonyms = map (anTypeDecl dt) typeDecls 19 | envTrans = anClassDecls dt classDecls <:> anInstDecls dt instDecls 20 | Just ce' = envTrans ce 21 | bs = anVarDecls dt varDecls ++ anPatBinds dt patBinds 22 | sigs = concat (map (anSigDecl dt) sigDecls) 23 | (main, bs') = partition ((== "@main") . fst) bs 24 | prog = makeBindGroups sigs bs' ++ 25 | [(expls ce', []), makeBindGroup sigs main] 26 | 27 | splitDecls tds = (dataDecls, typeDecls, classDecls, instDecls, 28 | varDecls, patBinds, sigDecls) 29 | where dataDecls = [dd | P.DataDecl dd <- tds] 30 | typeDecls = [td | P.TypeDecl td <- tds] 31 | classDecls = [cd | P.ClassDecl cd <- tds] 32 | instDecls = [id | P.InstDecl id <- tds] 33 | decls = [d | P.Decl d <- tds] 34 | varDecls = [vd | P.VarDecl vd <- decls] 35 | patBinds = [pb | P.PatBind pb <- decls] 36 | sigDecls = [sd | P.SigDecl sd <- decls] 37 | 38 | anDecls :: DataType -> [P.Decl] -> [BindGroup] 39 | anDecls dt decls = makeBindGroups sigs bs 40 | where bs = collectBinds vds ++ pbs 41 | vds = [anVarDecl dt a | P.VarDecl a <- decls] 42 | pbs = anPatBinds dt [pe | P.PatBind pe <- decls] 43 | sigs = concat [anSigDecl dt sd | P.SigDecl sd <- decls] 44 | 45 | anVarDecls :: DataType -> [(String, [P.Pat], P.Rhs)] -> [Impl] 46 | anVarDecls dt vds = collectBinds $ map (anVarDecl dt) vds 47 | 48 | anVarDecl :: DataType -> (String, [P.Pat], P.Rhs) -> (Id, Alt) 49 | anVarDecl dt (i, ps, rhs) = (i, alt) 50 | where alt = (map (anPat dt) ps, anRhs dt rhs) 51 | 52 | anRhs :: DataType -> P.Rhs -> Rhs 53 | anRhs dt rhs = foldr Where r (anDecls dt ds) 54 | where (r, ds) = case rhs of 55 | P.Rhs e ds -> (Rhs $ anExpr dt e, ds) 56 | P.Guarded gds ds -> (Guarded [(anExpr dt e, anExpr dt e') 57 | | (e, e') <- gds], ds) 58 | 59 | anPatBinds :: DataType -> [(P.Pat, P.Rhs)] -> [Impl] 60 | anPatBinds dt pes = concat [anPatBind dt n pe | (pe, n) <- zip pes [1..]] 61 | 62 | anPatBind :: DataType -> Int -> (P.Pat, P.Rhs) -> [Impl] 63 | anPatBind dt n (p, rhs) = conf : bs 64 | where conf = (newvar, [([], anRhs dt $ makeBindRhs p rhs)]) 65 | bs = patBindings (Var newvar) (anPat dt p) 66 | newvar = "Tmp#" ++ show n 67 | 68 | makeBindRhs :: P.Pat -> P.Rhs -> P.Rhs 69 | makeBindRhs p (P.Rhs e ds) = P.Rhs e' ds 70 | where e' = P.Case e [(P.AsPat "@u" p, P.Rhs (P.Var "@u") [])] 71 | makeBindRhs p (P.Guarded gds ds) = P.Guarded gds' ds 72 | where gds' = [(cond, P.Case e [(P.AsPat "@u" p, P.Rhs (P.Var "@u") [])]) 73 | | (cond, e) <- gds] 74 | 75 | anSigDecl :: DataType -> ([Id], P.Context, P.Type) -> [(Id, Scheme)] 76 | anSigDecl (tce, _) (is, ctx, t) = [(i, sc) | i <- is] 77 | where sc = quantifyAll (anContext ctx :=> anType tce t) 78 | 79 | makeBindGroups :: [(Id, Scheme)] -> [Impl] -> [BindGroup] 80 | makeBindGroups sigs bs = map (makeBindGroup sigs) (dependency bs) 81 | 82 | makeBindGroup :: [(Id, Scheme)] -> [Impl] -> BindGroup 83 | makeBindGroup sigs bs = (expls, [impls]) 84 | where bs' = map makeBind bs 85 | impls = [impl | Left impl <- bs'] 86 | expls = [expl | Right expl <- bs'] 87 | makeBind :: Impl -> Either Impl Expl 88 | makeBind (i, alts) = case lookup i sigs of 89 | Just sc -> Right (i, sc, alts) 90 | Nothing -> Left (i, alts) 91 | 92 | collectBinds :: [(Id, Alt)] -> [Impl] 93 | collectBinds [] = [] 94 | collectBinds bs = (id, map snd bs1) : rest 95 | where (id, _) = head bs 96 | (bs1, bs2) = partition ((== id) . fst) bs 97 | rest = collectBinds bs2 98 | 99 | anExpr :: DataType -> P.Expr -> Expr 100 | anExpr dt (P.Var i) = Var i 101 | anExpr (_, cs) (P.Con i) = 102 | case lookupConst i cs of 103 | Just con -> Con con 104 | Nothing -> error ("Undefined constructor function " ++ i) 105 | anExpr dt (P.Tuple es) = ap (Con (tupcon (length es))) (map (anExpr dt) es) 106 | anExpr dt (P.LitInt n) = Lit (LitInt n) 107 | anExpr dt (P.LitChar c) = Lit (LitChar c) 108 | anExpr dt (P.LitStr s) = foldr (\c e -> ap eCons [Lit $ LitChar [c], e]) eNil s 109 | anExpr dt (P.Ap e1 e2) = Ap (anExpr dt e1) (anExpr dt e2) 110 | anExpr dt (P.Let ds e) = foldr Let (anExpr dt e) (anDecls dt ds) 111 | anExpr dt (P.Lambda ps e) = 112 | Lambda (map (anPat dt) ps, Rhs $ anExpr dt e) 113 | anExpr dt@(tce, _) (P.ESign e ctx t) = 114 | ESign (anExpr dt e) (quantifyAll (anContext ctx :=> anType tce t)) 115 | anExpr dt (P.Case e as) = 116 | Case (anExpr dt e) [(anPat dt p, anRhs dt rhs) | (p, rhs) <- as] 117 | 118 | anPat :: DataType -> P.Pat -> Pat 119 | anPat dt (P.PVar i) = PVar i 120 | anPat dt@(_, cs) (P.PCon i ps) = 121 | case lookupConst i cs of 122 | Just con -> PCon con (map (anPat dt) ps) 123 | Nothing -> error ("Undefined constructor function " ++ i) 124 | anPat dt (P.PTuple ps) = PCon (tupcon (length ps)) (map (anPat dt) ps) 125 | anPat dt (P.PInt n) = PLit (LitInt n) 126 | anPat dt (P.PChar c) = PLit (LitChar c) 127 | anPat dt (P.PStr s) = foldr (\c e -> pCons (PLit $ LitChar [c]) e) pNil s 128 | anPat dt (P.AsPat i p) = PAs i (anPat dt p) 129 | anPat dt P.Wildcard = PWildcard 130 | 131 | anContext :: P.Context -> [Pred] 132 | anContext = map anPred 133 | where anPred (id, t) = IsIn id (anType ([],[]) t) 134 | 135 | anType :: TyconEnv -> P.Type -> Type 136 | anType tce t = anTypeAp tce t [] 137 | 138 | anTypeAp :: TyconEnv -> P.Type -> [Type] -> Type 139 | anTypeAp tce (P.TyAp t1 t2) ts = anTypeAp tce t1 (anType tce t2 : ts) 140 | anTypeAp tce (P.TyTuple _) (t:ts) = error "bad application" 141 | anTypeAp tce (P.TyTuple ts) [] = foldl TAp ttc ts' 142 | where ttc = TCon (tupTycon (length ts)) 143 | ts' = map (anType tce) ts 144 | anTypeAp tce (P.TyVar i) ts = foldl TAp (TVar (Tyvar i Star)) ts 145 | anTypeAp (tcs, syns) (P.TyCon i) ts = 146 | case (assoc i tcs, assoc i syns) of 147 | (Just tc, _) -> foldl TAp (TCon tc) ts 148 | (_, Just s@(Synonym i _ vs _)) -> 149 | let n = length vs 150 | (ts1, ts2) = splitAt n ts 151 | in if length ts1 == n then foldl TAp (TSynonym s ts1) ts2 152 | else error ("partial application of " ++ i) 153 | (Nothing, Nothing) -> error ("unknown type constructor " ++ i) 154 | 155 | 156 | anDataDecls :: [Synonym] -> [(P.Context, String, [String], [P.Constr])] 157 | -> DataType 158 | anDataDecls syns dts = (tcenv, constrs) 159 | where (userTycons, constrs_s) = unzip $ map (anDataDecl tcenv) dts 160 | tcenv = (preludeTycons ++ userTycons, preludeSynonyms ++ syns) 161 | constrs = concat (preludeConstrs : constrs_s) 162 | 163 | anDataDecl :: TyconEnv -> (P.Context, String, [String], [P.Constr]) 164 | -> (Tycon, [Const]) 165 | anDataDecl tce (ctx, con, vs, cs) = (tc, consts) 166 | where (qt, tc) = anDataLhs ctx con vs (length cs) arities 167 | consts = [Const { conName=i, conArity=a, conTag=tag, 168 | conTycon=tc, conScheme=sc} 169 | | (tag, (i, a, sc)) <- zip [1..] $ map (anConstr tce qt) cs] 170 | arities = [conArity c | c <- consts] 171 | 172 | anDataLhs :: P.Context -> String -> [String] -> Int -> [Int] 173 | -> (Qual Type, Tycon) 174 | anDataLhs ctx con vs n arities = 175 | (anContext ctx :=> foldl TAp (TCon tc) vs', tc) 176 | where k = foldr Kfun Star (replicate (length vs') Star) 177 | tc = Tycon con k n arities 178 | vs' = [TVar (Tyvar v Star) | v <- vs] 179 | 180 | anConstr :: TyconEnv -> Qual Type -> P.Constr -> (Id, Int, Scheme) 181 | anConstr tce (ps :=> dt) (i, ts) = 182 | case tv ts' \\ tv dt of 183 | [] -> (i, length ts', quantifyAll (ps :=> foldr fn dt ts')) 184 | (Tyvar i _ : _) -> error ("Undefined type variable " ++ i) 185 | where ts' = map (anType tce) ts 186 | 187 | anTypeDecl :: DataType -> (String, [String], P.Type) -> Synonym 188 | anTypeDecl (tce,_) (id, vs, t) = Synonym id k vs' t' 189 | where k = foldr Kfun Star (replicate (length vs) Star) 190 | vs' = [Tyvar v Star | v <- vs] 191 | t' = anType tce t 192 | -- FIXME: kind inference needed 193 | 194 | ----------------------------------------------------------------------------- 195 | -- class declaration 196 | 197 | anClassDecls :: DataType 198 | -> [(P.Context, String, P.Type, [P.Decl])] 199 | -> EnvTransformer 200 | -- FIXME: check for cyclic inheritance 201 | anClassDecls dt cds = foldl (<:>) idEnvTransformer (map (anClassDecl dt) cds) 202 | 203 | anClassDecl :: DataType 204 | -> (P.Context, String, P.Type, [P.Decl]) 205 | -> EnvTransformer 206 | anClassDecl dt classDecl@(sup, id, v, decls) = 207 | T.addClass id (map fst sup) as <:> T.addImpls impls <:> T.addExpls expls 208 | where as = [i :>: sc | P.SigDecl (is, ctx, t) <- decls, 209 | (i, sc) <- anSigDecl dt (is, (id, v) : ctx, t) ] 210 | impls = selectors classDecl as 211 | expls = anDefaultMethodDecl dt as decls 212 | 213 | selectors :: (P.Context, String, P.Type, [P.Decl]) -> [Assump] -> [Impl] 214 | selectors (sup, id, v, decls) as = supers ++ methods 215 | where supers = [superSelector s id k dictsize 216 | | ((s, _), k) <- zip sup [0..]] 217 | methods = [tupleSelector m k dictsize 218 | | (m :>: _, k) <- zip as [length sup..]] 219 | dictsize = length sup + length as 220 | 221 | superSelector :: String -> String -> Int -> Int -> Impl 222 | superSelector sup cls = tupleSelector (cls ++ ">>" ++ sup) 223 | 224 | anDefaultMethodDecl :: DataType -> [Assump] -> [P.Decl] -> [Expl] 225 | anDefaultMethodDecl dt as decls = map makeExpl impls 226 | where impls = anVarDecls dt [a | P.VarDecl a <- decls] 227 | makeExpl (id, alts) = 228 | case findAssump id as of 229 | Just sc -> (defaultMethodId id, sc, alts) 230 | Nothing -> error ("undeclared method: " ++ id) 231 | 232 | ----------------------------------------------------------------------------- 233 | -- instance declaration 234 | 235 | anInstDecls :: DataType -> [(P.Context, String, P.Type, [P.Decl])] 236 | -> EnvTransformer 237 | anInstDecls dt ids = foldl (<:>) idEnvTransformer (map (anInstDecl dt) ids) 238 | 239 | anInstDecl :: DataType -> (P.Context, String, P.Type, [P.Decl]) 240 | -> EnvTransformer 241 | anInstDecl dt@(tce,_) (ctx, id, t, decls) ce = 242 | (addinst <:> T.addExpls es <:> T.addImpls [dict]) ce 243 | where addinst = T.addInst ps p (Var dictid) 244 | ps = anContext ctx 245 | t' = anType tce t 246 | p = IsIn id t' 247 | dataid = makeDataId t' 248 | dictid = id ++ dataid 249 | (bounded, es) = unzip (anInstMethodDecl ce dt ps p decls) 250 | dict = makeDict ce ps p dictid bounded 251 | 252 | makeDict :: ClassEnv -> [Pred] -> Pred -> Id -> [Id] -> Impl 253 | makeDict ce ps pred dictid bounded = (dictid, alts) 254 | where alts = T.resolve ce [] [] ps [([], Rhs expr)] 255 | expr = tuple (supers ++ methods) 256 | supers = superDict ce pred 257 | methods = methodDict ce ps pred dictid bounded 258 | 259 | superDict :: ClassEnv -> Pred -> [Expr] 260 | superDict ce (IsIn cls t) = [ClassPH (IsIn sup t) | sup <- T.super ce cls] 261 | 262 | methodDict :: ClassEnv -> [Pred] -> Pred -> Id -> [Id] -> [Expr] 263 | methodDict ce ps (IsIn cls t) dictid bounded = 264 | [entry mth | mth :>: _ <- T.methods ce cls] 265 | where entry id = if elem id bounded 266 | then foldl Ap (Var (methodId id t)) phs 267 | else Ap (Var (defaultMethodId id)) 268 | (foldl Ap (Var dictid) phs) 269 | phs = map ClassPH ps 270 | 271 | {- memo 272 | Class Show a where 273 | show :: a -> String 274 | 275 | instance (Show c, Show d) => Show (c, d) where 276 | show (x, y) = "(" ++ show x ++ ", " ++ show y ++ ")" 277 | 278 | showTup :: (Show c, Show d) => (c, d) -> String 279 | 280 | show :: (Show a) => a -> String 281 | -} 282 | anInstMethodDecl :: ClassEnv -> DataType -> [Pred] -> Pred -> [P.Decl] 283 | -> [(Id, Expl)] 284 | anInstMethodDecl ce dt ps (IsIn cls t) decls = 285 | [(id, (methodId id t, sig id, alts)) | (id, alts) <- impls] 286 | where impls = anVarDecls dt [a | P.VarDecl a <- decls] 287 | sig :: Id -> Scheme 288 | sig id = quantifyAll ((ps' ++ apply sub ps) :=> apply sub t') 289 | where sub = [(v, t)] 290 | (IsIn cls' (TVar v) : ps') :=> t' = T.runTI (T.freshInst sc) 291 | Just sc = findAssump id (T.methods ce cls) 292 | 293 | methodId :: Id -> Type -> Id 294 | methodId mth t = mth ++ '#' : makeDataId t 295 | 296 | defaultMethodId :: Id -> Id 297 | defaultMethodId mth = mth ++ "#" 298 | 299 | makeDataId :: Type -> Id 300 | makeDataId t = 301 | case head (fromTAp t) of 302 | TCon tc -> if tyconName tc == "(,)" 303 | then '(' : show (tyconKind tc) ++ ")" 304 | else tyconName tc 305 | 306 | lookupConst i cs = lookup i [(conName c, c) | c <- cs] 307 | -------------------------------------------------------------------------------- /Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | import Data.Char(chr, ord) 3 | import Data.List(find, nub, union, intersect, (\\)) 4 | import SCC 5 | 6 | type Id = String 7 | type Alt = ([Pat], Rhs) 8 | type Expl = (Id, Scheme, [Alt]) 9 | type Impl = (Id, [Alt]) 10 | type BindGroup = ([Expl], [[Impl]]) 11 | type Program = [BindGroup] 12 | 13 | data Kind = Star | Kfun Kind Kind 14 | deriving (Eq, Show) 15 | 16 | class Assoc a where 17 | assocKey :: a -> String 18 | assoc :: String -> [a] -> Maybe a 19 | assoc key [] = Nothing 20 | assoc key (x:xs) = if assocKey x == key then Just x else assoc key xs 21 | 22 | ----------------------------------------------------------------------------- 23 | -- Type: Types 24 | ----------------------------------------------------------------------------- 25 | 26 | data Type = TVar Tyvar 27 | | TCon Tycon 28 | | TAp Type Type 29 | | TGen Int 30 | | TSynonym Synonym [Type] 31 | deriving Eq 32 | 33 | instance Show Type where 34 | showsPrec _ (TVar v) = shows v 35 | showsPrec _ (TCon c) = shows c 36 | showsPrec _ (TSynonym syn []) = shows syn 37 | showsPrec p (TSynonym syn ts) = showParen (p > 2) f 38 | where f = shows syn . (' ':) . g 39 | g = foldr1 (\l r -> l . (' ':) . r) (map (showsPrec 3) ts) 40 | showsPrec _ (TGen n) = (chr (ord 'a' + n) :) 41 | showsPrec p tap@(TAp _ _) = 42 | case t of 43 | TCon tc | tyconName tc == "[]" 44 | -> ('[':) . showsPrec 0 t1 . (']':) 45 | where [t1] = ts 46 | TCon tc | tyconName tc == "(->)" 47 | -> showParen (p > 0) $ 48 | showsPrec 1 t1 . (" -> " ++) . showsPrec 0 t2 49 | where [t1, t2] = ts 50 | TCon tc | tyconName tc == "(,)" 51 | -> showParen True $ 52 | foldr1 (\f g -> f . (", " ++) . g) 53 | (map (showsPrec 0) ts) 54 | _ -> showParen (p > 2) $ 55 | foldr1 (\f g -> f . (' ':) . g) 56 | (map (showsPrec 3) (t:ts)) 57 | where (t:ts) = fromTAp tap 58 | 59 | fromTAp :: Type -> [Type] 60 | fromTAp (TAp t1 t2) = fromTAp t1 ++ [t2] 61 | fromTAp t = [t] 62 | 63 | data Tyvar = Tyvar Id Kind deriving Eq 64 | 65 | instance Show Tyvar where 66 | show (Tyvar id _) = id 67 | 68 | data Tycon = Tycon { tyconName::Id, 69 | tyconKind::Kind, 70 | tyconNumCon::Int, 71 | tyconArities::[Int] 72 | } deriving Eq 73 | 74 | instance Show Tycon where 75 | show tc = tyconName tc 76 | 77 | data Synonym = Synonym Id Kind [Tyvar] Type deriving Eq 78 | 79 | instance Show Synonym where 80 | show (Synonym id _ _ _) = id 81 | 82 | instance Assoc Tycon where 83 | assocKey tc = tyconName tc 84 | 85 | instance Assoc Synonym where 86 | assocKey (Synonym i _ _ _) = i 87 | 88 | unsynonym :: Synonym -> [Type] -> Type 89 | unsynonym (Synonym _ _ vs t) ts = apply s t 90 | where s = zip vs ts 91 | 92 | tChar = TCon (Tycon "Char" Star 0 []) 93 | tInt = TCon (Tycon "Int" Star 0 []) 94 | tBool = TCon (Tycon "Bool" Star 2 [0,0]) 95 | tUnit = TCon (Tycon "()" Star 1 [0]) 96 | tList = TCon (Tycon "[]" (Kfun Star Star) 2 [2,0]) 97 | tArrow = TCon (Tycon "(->)" (Kfun Star (Kfun Star Star)) 0 []) 98 | 99 | tString :: Type 100 | tString = list tChar 101 | 102 | preludeTycons :: [Tycon] 103 | preludeTycons = [Tycon "()" Star 1 [0], 104 | Tycon "Char" Star 0 [], 105 | Tycon "Int" Star 0 [], 106 | Tycon "Bool" Star 2 [0,0], 107 | Tycon "[]" (Kfun Star Star) 2 [2,0], 108 | Tycon "(->)" (Kfun Star (Kfun Star Star)) 0 [] 109 | ] 110 | 111 | preludeSynonyms :: [Synonym] 112 | preludeSynonyms = [Synonym "String" Star [] (list tChar) 113 | ] 114 | 115 | preludeConstrs :: [Const] 116 | preludeConstrs = [Const { conName = i, 117 | conArity = a, 118 | conTag = tag, 119 | conTycon = tycon, 120 | conScheme = quantifyAll' t } 121 | | (i, a, tag, TCon tycon, t) <- constrs] 122 | where a = TVar (Tyvar "a" Star) 123 | constrs = [("True", 0, 1, tBool, tBool), 124 | ("False", 0, 2, tBool, tBool), 125 | (":", 2, 1, tList, a `fn` list a `fn` list a), 126 | ("[]", 0, 2, tList, list a)] 127 | 128 | eTrue = Con con 129 | where Just con = find (\c -> conName c == "True") preludeConstrs 130 | eFalse = Con con 131 | where Just con = find (\c -> conName c == "False") preludeConstrs 132 | eCons = Con con 133 | where Just con = find (\c -> conName c == ":") preludeConstrs 134 | eNil = Con con 135 | where Just con = find (\c -> conName c == "[]") preludeConstrs 136 | pCons x y = PCon con [x, y] 137 | where Just con = find (\c -> conName c == ":") preludeConstrs 138 | pNil = PCon con [] 139 | where Just con = find (\c -> conName c == "[]") preludeConstrs 140 | 141 | infixr 4 `fn` 142 | fn :: Type -> Type -> Type 143 | a `fn` b = TAp (TAp tArrow a) b 144 | 145 | list :: Type -> Type 146 | list t = TAp tList t 147 | 148 | pair :: Type -> Type -> Type 149 | pair a b = TCon (tupTycon 2) `fn` a `fn` b 150 | 151 | class HasKind t where 152 | kind :: t -> Kind 153 | instance HasKind Tyvar where 154 | kind (Tyvar v k) = k 155 | instance HasKind Tycon where 156 | kind tc = tyconKind tc 157 | instance HasKind Synonym where 158 | kind (Synonym _ k _ _) = k 159 | instance HasKind Type where 160 | kind (TCon tc) = kind tc 161 | kind (TVar u) = kind u 162 | kind (TAp t _) = case (kind t) of 163 | (Kfun _ k) -> k 164 | kind (TSynonym syn ts) = kind (unsynonym syn ts) 165 | 166 | type Subst = [(Tyvar, Type)] 167 | 168 | class Types t where 169 | apply :: Subst -> t -> t 170 | tv :: t -> [Tyvar] 171 | 172 | instance Types Type where 173 | apply s (TVar u) = case lookup u s of 174 | Just t -> t 175 | Nothing -> TVar u 176 | apply s (TAp l r) = TAp (apply s l) (apply s r) 177 | apply s t = t 178 | 179 | tv (TVar u) = [u] 180 | tv (TAp l r) = tv l `union` tv r 181 | tv t = [] 182 | 183 | instance Types a => Types [a] where 184 | apply s = map (apply s) 185 | tv = nub . concat . map tv 186 | 187 | -- Predicates 188 | data Qual t = [Pred] :=> t 189 | deriving Eq 190 | 191 | data Pred = IsIn Id Type 192 | deriving Eq 193 | 194 | instance Types t => Types (Qual t) where 195 | apply s (ps :=> t) = apply s ps :=> apply s t 196 | tv (ps :=> t) = tv ps `union` tv t 197 | 198 | instance Types Pred where 199 | apply s (IsIn i t) = IsIn i (apply s t) 200 | tv (IsIn i t) = tv t 201 | 202 | instance (Show t) => Show (Qual t) where 203 | showsPrec _ ([] :=> t) = shows t 204 | showsPrec _ (p :=> t) = showsContext . (" => " ++) . shows t 205 | where showsContext = showParen True $ 206 | foldr1 (\f g -> f . (", " ++) . g) (map shows p) 207 | 208 | instance Show Pred where 209 | showsPrec _ (IsIn id t) = (id ++) . (' ':) . shows t 210 | 211 | -- Type schemes 212 | data Scheme = Forall [Kind] (Qual Type) 213 | deriving Eq 214 | 215 | instance Show Scheme where 216 | showsPrec _ (Forall _ qt) = shows qt 217 | 218 | instance Types Scheme where 219 | apply s (Forall ks t) = Forall ks (apply s t) 220 | tv (Forall ks t) = tv t 221 | 222 | quantify :: [Tyvar] -> Qual Type -> Scheme 223 | quantify vs qt = Forall ks (apply s qt) 224 | where vs' = [ v | v <- tv qt, v `elem` vs ] 225 | ks = map kind vs' 226 | s = zip vs' (map TGen [0..]) 227 | 228 | quantifyAll :: Qual Type -> Scheme 229 | quantifyAll t = quantify (tv t) t 230 | 231 | quantifyAll' :: Type -> Scheme 232 | quantifyAll' t = quantify (tv t) ([] :=> t) 233 | 234 | toScheme :: Type -> Scheme 235 | toScheme t = Forall [] ([] :=> t) 236 | 237 | -- Assumptions 238 | data Assump = Id :>: Scheme 239 | 240 | instance Show Assump where 241 | show (i :>: sc) = show i ++ " :: " ++ show sc 242 | 243 | instance Types Assump where 244 | apply s (i :>: sc) = i :>: (apply s sc) 245 | tv (i :>: sc) = tv sc 246 | 247 | findAssump :: Monad m => Id -> [Assump] -> m Scheme 248 | findAssump id [] = fail ("unbound identifier: " ++ id) 249 | findAssump id ((i:>:sc):as) = if i == id then return sc else findAssump id as 250 | 251 | -- Literals 252 | data Literal = LitInt Int 253 | | LitChar String 254 | | LitStr String 255 | deriving Eq 256 | 257 | instance Show Literal where 258 | show (LitInt n) = show n 259 | show (LitChar c) = c 260 | show (LitStr s) = s 261 | 262 | -- Patterns 263 | data Pat = PVar Id 264 | | PWildcard 265 | | PAs Id Pat 266 | | PLit Literal 267 | | PCon Const [Pat] 268 | 269 | data Expr = Var Id 270 | | Lit Literal 271 | | Con Const 272 | | Ap Expr Expr 273 | | Let BindGroup Expr 274 | | Case Expr [(Pat, Rhs)] 275 | | Lambda Alt 276 | | ESign Expr Scheme 277 | | RecPH Id 278 | | ClassPH Pred 279 | 280 | data Rhs = Rhs Expr 281 | | Where BindGroup Rhs 282 | | Guarded [(Expr, Expr)] 283 | 284 | data Const = Const { conName::Id, 285 | conArity::Int, 286 | conTag::Int, 287 | conTycon::Tycon, 288 | conScheme::Scheme } 289 | 290 | instance Eq Const where 291 | c1 == c2 = conName c1 == conName c2 292 | 293 | ap :: Expr -> [Expr] -> Expr 294 | ap = foldl Ap 295 | 296 | bindings :: BindGroup -> [Impl] 297 | bindings (es, iss) = [(i, as) | (i, _, as) <- es] ++ concat iss 298 | 299 | class HasVar t where 300 | freeVars :: t -> [Id] 301 | 302 | instance HasVar Expr where 303 | freeVars (Var i) = [i] 304 | freeVars (Ap e1 e2) = freeVars e1 `union` freeVars e2 305 | freeVars (Let bg e) = fvBindGroup bg `union` 306 | (freeVars e \\ map fst (bindings bg)) 307 | freeVars (Case e pses) = foldr union fve fvas 308 | where fve = freeVars e 309 | fvas = [freeVars e' \\ patVars p | (p, e') <- pses] 310 | freeVars (Lambda a) = fvAlt a 311 | freeVars (ESign e _) = freeVars e 312 | freeVars _ = [] 313 | 314 | instance HasVar Rhs where 315 | freeVars (Rhs e) = freeVars e 316 | freeVars (Where bg rhs) = 317 | fvBindGroup bg `union` (freeVars rhs \\ map fst (bindings bg)) 318 | freeVars (Guarded pairs) = 319 | foldr union [] [freeVars e `union` freeVars e' | (e, e') <- pairs] 320 | 321 | fvBindGroup :: BindGroup -> [Id] 322 | fvBindGroup bg = fvAlts (concat altss) \\ is 323 | where (is, altss) = unzip (bindings bg) 324 | 325 | fvAlts :: [Alt] -> [Id] 326 | fvAlts alts = foldl1 union (map fvAlt alts) 327 | fvAlt :: Alt -> [Id] 328 | fvAlt (ps, rhs) = freeVars rhs \\ concat (map patVars ps) 329 | 330 | patVars :: Pat -> [Id] 331 | patVars (PVar i) = [i] 332 | patVars (PAs i p) = i : patVars p 333 | patVars (PCon _ ps) = concat (map patVars ps) 334 | patVars _ = [] 335 | 336 | tupcon :: Int -> Const 337 | tupcon n = Const "(,)" n 1 tycon sc 338 | where tycon = tupTycon n 339 | tuptype = foldl TAp (TCon tycon) tvars 340 | {- 341 | tvars = [TVar (Tyvar ('v' : show i) Star) | i <- [0..n-1]] 342 | scheme = quantifyAll (foldr fn tuptype tvars) 343 | -} 344 | tvars = [TGen i | i <- [0..n-1]] 345 | sc = Forall (replicate n Star) ([] :=> foldr fn tuptype tvars) 346 | 347 | 348 | tupTycon :: Int -> Tycon 349 | tupTycon n = Tycon "(,)" (foldr Kfun Star (replicate n Star)) 1 [0] 350 | 351 | tuple :: [Expr] -> Expr 352 | tuple es = foldl Ap (Con $ tupcon $ length es) es 353 | 354 | tupleSelector :: String -> Int -> Int -> Impl 355 | tupleSelector id k n = (id, [([pat], Rhs expr)]) 356 | where pat = PCon (tupcon n) [PVar ('e' : show i) | i <- [0..n-1]] 357 | expr = Var ('e' : show k) 358 | 359 | -- type class 360 | 361 | type Class = ([Id], [Inst], [Assump]) 362 | type Inst = (Qual Pred, Expr) 363 | 364 | data ClassEnv = ClassEnv { classes :: Id -> Maybe Class, 365 | defaults :: [Type], 366 | impls :: [Impl], 367 | expls :: [Expl], 368 | assumps :: [Assump] } 369 | 370 | type EnvTransformer = ClassEnv -> Maybe ClassEnv 371 | idEnvTransformer :: EnvTransformer 372 | idEnvTransformer ce = Just ce 373 | 374 | infixr 5 <:> 375 | (<:>) :: EnvTransformer -> EnvTransformer -> EnvTransformer 376 | (f <:> g) ce = do ce' <- f ce 377 | g ce' 378 | 379 | -- SKI expression 380 | data SKI = SAp SKI SKI 381 | | SLit Literal 382 | | SVar Id 383 | | SCon Int Int 384 | 385 | sap :: SKI -> [SKI] -> SKI 386 | sap = foldl SAp 387 | 388 | instance Show SKI where 389 | show e = showsPrec 1 e "" 390 | showsPrec _ (SVar i) = (i++) 391 | showsPrec _ (SLit l) = shows l 392 | showsPrec _ (SCon k n) = ('@':) . shows k . ('_':) . shows n 393 | showsPrec _ (SAp e1 e2) = ('`':) . shows e1 . shows e2 394 | -- showsPrec p (SAp e1 e2) = showParen (p > 0) $ 395 | -- showsPrec 0 e1 . (' ':) . showsPrec 1 e2 396 | 397 | dependency :: [Impl] -> [[Impl]] 398 | dependency bs = (map . map) (\v -> (v, lookup' v bs)) (reverse vss) 399 | where vs = map fst bs 400 | vss = scc [(v, fvAlts alts `intersect` vs) | (v, alts) <- bs] 401 | lookup' key xs = case lookup key xs of 402 | Just x -> x 403 | Nothing -> error "cannot occur" 404 | -------------------------------------------------------------------------------- /Test.hs: -------------------------------------------------------------------------------- 1 | import HUnit 2 | import Syntax 3 | import qualified Parser as P 4 | import qualified Static as S 5 | 6 | tcList = Tycon "List" (Kfun Star Star) 2 7 | tyList = TAp (TCon tcList) (TVar (Tyvar "a" Star)) 8 | 9 | tests = 10 | ["test_anDataLhs" ~: -- data List a = Cons a (List a) | Nil 11 | let pList = (P.TyAp (P.TyCon "List") (P.TyVar "a")) 12 | in assertEqual "1" (tyList, tcList) (S.anDataLhs pList 2), 13 | "test_anConstr" ~: 14 | let constr = P.TyAp (P.TyAp (P.TyCon "Cons") (P.TyVar "a")) 15 | (P.TyAp (P.TyCon "List") (P.TyVar "a")) 16 | typeArgs = [TVar (Tyvar "a" Star), tyList] 17 | in assertEqual "1" ("Cons", typeArgs, tyList) 18 | (S.anConstr [tcList] tyList constr) 19 | ] 20 | 21 | main = runTestTT $ test tests 22 | -------------------------------------------------------------------------------- /Type.hs: -------------------------------------------------------------------------------- 1 | -- Part of `Typing Haskell in Haskell', version of November 23, 2000 2 | -- Copyright (c) Mark P Jones and the Oregon Graduate Institute 3 | -- of Science and Technology, 1999-2000 4 | -- 5 | -- This program is distributed as Free Software under the terms 6 | -- in the file "License" that is included in the distribution 7 | -- of this software, copies of which may be obtained from: 8 | -- http://www.cse.ogi.edu/~mpj/thih/ 9 | -- 10 | -- modified by irori 11 | 12 | module Type where 13 | import Data.List(nub, (\\), intersect, union, partition) 14 | import Control.Monad(msum) 15 | import Syntax 16 | 17 | enumId :: Int -> Id 18 | enumId n = "v" ++ show n 19 | 20 | -- Substitutions 21 | nullSubst :: Subst 22 | nullSubst = [] 23 | 24 | (+->) :: Tyvar -> Type -> Subst 25 | u +-> t = [(u, t)] 26 | 27 | infixr 4 @@ 28 | (@@) :: Subst -> Subst -> Subst 29 | s1 @@ s2 = [ (u, apply s1 t) | (u,t) <- s2 ] ++ s1 30 | 31 | merge :: Monad m => Subst -> Subst -> m Subst 32 | merge s1 s2 = if agree then return (s1++s2) else fail "merge fails" 33 | where agree = all (\v -> apply s1 (TVar v) == apply s2 (TVar v)) 34 | (map fst s1 `intersect` map fst s2) 35 | 36 | -- Unification 37 | mgu :: Monad m => Type -> Type -> m Subst 38 | varBind :: Monad m => Tyvar -> Type -> m Subst 39 | 40 | mgu (TAp l r) (TAp l' r') = do s1 <- mgu l l' 41 | s2 <- mgu (apply s1 r) (apply s1 r') 42 | return (s2 @@ s1) 43 | mgu (TVar u) t = varBind u t 44 | mgu t (TVar u) = varBind u t 45 | mgu (TSynonym s ts) u = mgu (unsynonym s ts) u 46 | mgu t (TSynonym s ts) = mgu t (unsynonym s ts) 47 | mgu (TCon tc1) (TCon tc2) 48 | | tc1==tc2 = return nullSubst 49 | mgu t1 t2 = fail ("types do not unify: " 50 | ++ show t1 ++ " " ++ show t2) 51 | 52 | varBind u t | t == TVar u = return nullSubst 53 | | u `elem` tv t = fail "occurs check fails" 54 | | kind u /= kind t = fail "kinds do not match" 55 | | otherwise = return (u +-> t) 56 | 57 | match :: Monad m => Type -> Type -> m Subst 58 | 59 | match (TAp l r) (TAp l' r') = do sl <- match l l' 60 | sr <- match r r' 61 | merge sl sr 62 | match (TVar u) t | kind u == kind t = return (u +-> t) 63 | match (TSynonym s ts) u = match (unsynonym s ts) u 64 | match t (TSynonym s ts) = match t (unsynonym s ts) 65 | match (TCon tc1) (TCon tc2) 66 | | tc1==tc2 = return nullSubst 67 | match t1 t2 = fail "types do not match" 68 | 69 | ----------------------------------------------------------------------------- 70 | -- Pred: Predicates 71 | ----------------------------------------------------------------------------- 72 | 73 | mguPred, matchPred :: Pred -> Pred -> Maybe Subst 74 | mguPred = lift mgu 75 | matchPred = lift match 76 | 77 | lift m (IsIn i t) (IsIn i' t') 78 | | i == i' = m t t' 79 | | otherwise = fail "classes differ" 80 | 81 | ----------------------------------------------------------------------------- 82 | 83 | super :: ClassEnv -> Id -> [Id] 84 | super ce i = case classes ce i of 85 | Just (is, its, ms) -> is 86 | Nothing -> error ("super " ++ i) 87 | 88 | insts :: ClassEnv -> Id -> [Inst] 89 | insts ce i = case classes ce i of Just (is, its, ms) -> its 90 | 91 | methods :: ClassEnv -> Id -> [Assump] 92 | methods ce i = case classes ce i of Just (is, its, ms) -> ms 93 | 94 | defined :: Maybe a -> Bool 95 | defined (Just x) = True 96 | defined Nothing = False 97 | 98 | modify :: ClassEnv -> Id -> Class -> ClassEnv 99 | modify ce i c = ce{classes = \j -> if i==j then Just c 100 | else classes ce j} 101 | 102 | initialEnv :: ClassEnv 103 | initialEnv = ClassEnv { classes = \i -> fail "class not defined", 104 | defaults = [], 105 | impls = [], 106 | expls = [], 107 | assumps = [] } 108 | 109 | addClass :: Id -> [Id] -> [Assump] -> EnvTransformer 110 | addClass i is ms ce 111 | | defined (classes ce i) = fail "class already defined" 112 | | any (not . defined . classes ce) is = fail "superclass not defined" 113 | | otherwise = return (modify (ce{assumps = assumps ce ++ ms}) i (is, [], ms)) 114 | 115 | addInst :: [Pred] -> Pred -> Expr -> EnvTransformer 116 | addInst ps p@(IsIn i _) dict ce 117 | | not (defined (classes ce i)) = error ("no class for instance " ++ i) 118 | | any (overlap p) qs = error ("overlapping instance " ++ i) 119 | | otherwise = return (modify ce i c) 120 | where its = insts ce i 121 | qs = [ q | (_ :=> q, _) <- its ] 122 | c = (super ce i, (ps:=>p, dict) : its, methods ce i) 123 | 124 | addImpls :: [Impl] -> EnvTransformer 125 | addImpls is ce = return (ce { impls = impls ce ++ is }) 126 | 127 | addExpls :: [Expl] -> EnvTransformer 128 | addExpls es ce = return (ce { expls = expls ce ++ es }) 129 | 130 | addAssumps :: [Assump] -> EnvTransformer 131 | addAssumps is ce = return (ce { assumps = assumps ce ++ is }) 132 | 133 | overlap :: Pred -> Pred -> Bool 134 | overlap p q = defined (mguPred p q) 135 | 136 | {- 137 | exampleInsts :: EnvTransformer 138 | exampleInsts = addPreludeClasses 139 | <:> addInst [] (IsIn "Ord" tUnit) 140 | <:> addInst [] (IsIn "Ord" tChar) 141 | <:> addInst [] (IsIn "Ord" tInt) 142 | <:> addInst [IsIn "Ord" (TVar (Tyvar "a" Star)), 143 | IsIn "Ord" (TVar (Tyvar "b" Star))] 144 | (IsIn "Ord" (pair (TVar (Tyvar "a" Star)) 145 | (TVar (Tyvar "b" Star)))) 146 | -} 147 | 148 | ----------------------------------------------------------------------------- 149 | 150 | bySuper :: ClassEnv -> Pred -> [Pred] 151 | bySuper ce p@(IsIn i t) 152 | = p : concat [ bySuper ce (IsIn i' t) | i' <- super ce i ] 153 | 154 | byInst :: ClassEnv -> Pred -> Maybe ([Pred], Expr) 155 | byInst ce p@(IsIn i t) = msum [ tryInst it | it <- insts ce i ] 156 | where tryInst (ps :=> h, dict) = do u <- matchPred h p 157 | Just (map (apply u) ps, dict) 158 | 159 | entail :: ClassEnv -> [Pred] -> Pred -> Bool 160 | entail ce ps p = any (p `elem`) (map (bySuper ce) ps) || 161 | case byInst ce p of 162 | Nothing -> False 163 | Just (qs, _) -> all (entail ce ps) qs 164 | 165 | ----------------------------------------------------------------------------- 166 | 167 | inHnf :: Pred -> Bool 168 | inHnf (IsIn c t) = hnf t 169 | where hnf (TVar v) = True 170 | hnf (TCon tc) = False 171 | hnf (TAp t _) = hnf t 172 | hnf (TSynonym s ts) = hnf (unsynonym s ts) 173 | 174 | toHnfs :: Monad m => ClassEnv -> [Pred] -> m [Pred] 175 | toHnfs ce ps = do pss <- mapM (toHnf ce) ps 176 | return (concat pss) 177 | 178 | toHnf :: Monad m => ClassEnv -> Pred -> m [Pred] 179 | toHnf ce p | inHnf p = return [p] 180 | | otherwise = case byInst ce p of 181 | Nothing -> fail ("context reduction " ++ show p) 182 | Just (ps, _) -> toHnfs ce ps 183 | 184 | simplify :: ClassEnv -> [Pred] -> [Pred] 185 | simplify ce = loop [] 186 | where loop rs [] = rs 187 | loop rs (p:ps) | entail ce (rs++ps) p = loop rs ps 188 | | otherwise = loop (p:rs) ps 189 | 190 | reduce :: Monad m => ClassEnv -> [Pred] -> m [Pred] 191 | reduce ce ps = do qs <- toHnfs ce ps 192 | return (simplify ce qs) 193 | 194 | scEntail :: ClassEnv -> [Pred] -> Pred -> Bool 195 | scEntail ce ps p = any (p `elem`) (map (bySuper ce) ps) 196 | 197 | 198 | -- Type inference monad 199 | newtype TI a = TI (Subst -> Int -> (Subst, Int, a)) 200 | 201 | instance Monad TI where 202 | return x = TI (\s n -> (s,n,x)) 203 | TI f >>= g = TI (\s n -> case f s n of 204 | (s',m,x) -> let TI gx = g x 205 | in gx s' m) 206 | 207 | runTI :: TI a -> a 208 | runTI (TI f) = x where (s,n,x) = f nullSubst 0 209 | 210 | getSubst :: TI Subst 211 | getSubst = TI (\s n -> (s,n,s)) 212 | 213 | unify :: Type -> Type -> TI () 214 | unify t1 t2 = do s <- getSubst 215 | u <- mgu (apply s t1) (apply s t2) 216 | extSubst u 217 | 218 | extSubst :: Subst -> TI () 219 | extSubst s' = TI (\s n -> (s'@@s, n, ())) 220 | 221 | newTVar :: Kind -> TI Type 222 | newTVar k = TI (\s n -> let v = Tyvar (enumId n) k 223 | in (s, n+1, TVar v)) 224 | 225 | freshInst :: Scheme -> TI (Qual Type) 226 | freshInst (Forall ks qt) = do ts <- mapM newTVar ks 227 | return (inst ts qt) 228 | 229 | class Instantiate t where 230 | inst :: [Type] -> t -> t 231 | instance Instantiate Type where 232 | inst ts (TAp l r) = TAp (inst ts l) (inst ts r) 233 | inst ts (TGen n) = ts !! n 234 | inst ts t = t 235 | instance Instantiate a => Instantiate [a] where 236 | inst ts = map (inst ts) 237 | instance Instantiate t => Instantiate (Qual t) where 238 | inst ts (ps :=> t) = inst ts ps :=> inst ts t 239 | instance Instantiate Pred where 240 | inst ts (IsIn c t) = IsIn c (inst ts t) 241 | 242 | ----------------------------------------------------------------------------- 243 | -- TIMain: Type Inference Algorithm 244 | ----------------------------------------------------------------------------- 245 | 246 | type RecAssump = (Id, Type) 247 | data Env = Env [Assump] [RecAssump] 248 | 249 | instance Types Env where 250 | apply s (Env as ras) = Env (apply s as) [(i, apply s t) | (i, t) <- ras] 251 | tv (Env as ras) = tv as `union` tv (map snd ras) 252 | 253 | makeEnv :: [Assump] -> Env 254 | makeEnv as = Env as [] 255 | 256 | extend :: Env -> [Assump] -> Env 257 | extend (Env as ras) as' = Env (as' ++ as) ras 258 | 259 | extendRec :: Env -> [RecAssump] -> Env 260 | extendRec (Env as ras) ras' = Env as (ras' ++ ras) 261 | 262 | lookupEnv :: Monad m => Env -> Id -> m (Either Scheme Type) 263 | lookupEnv (Env as ras) i = 264 | case lookup i ras of 265 | Just t -> return (Right t) 266 | Nothing -> find as 267 | where find [] = fail ("unbound identifier: " ++ i) 268 | find ((i':>:sc):as) = if i==i' then return (Left sc) else find as 269 | 270 | -- Basic definitions for type inference 271 | type Infer e t = ClassEnv -> Env -> e -> TI ([Pred], t, e) 272 | 273 | -- Lit: Literals 274 | tiLit :: Literal -> TI ([Pred], Type) 275 | tiLit (LitChar _) = return ([], tChar) 276 | tiLit (LitInt _) = return ([], tInt) 277 | tiLit (LitStr _) = return ([], tString) 278 | 279 | -- Pat: Patterns 280 | tiPat :: Pat -> TI ([Pred], [Assump], Type) 281 | 282 | tiPat (PVar i) = do v <- newTVar Star 283 | return ([], [i :>: toScheme v], v) 284 | 285 | tiPat PWildcard = do v <- newTVar Star 286 | return ([], [], v) 287 | 288 | tiPat (PAs i pat) = do (ps, as, t) <- tiPat pat 289 | return (ps, (i:>:toScheme t):as, t) 290 | 291 | tiPat (PLit l) = do (ps, t) <- tiLit l 292 | return (ps, [], t) 293 | 294 | tiPat (PCon con pats) 295 | = do (ps, as, ts) <- tiPats pats 296 | t' <- newTVar Star 297 | (qs :=> t) <- freshInst (conScheme con) 298 | unify t (foldr fn t' ts) 299 | return (ps ++ qs, as, t') 300 | 301 | tiPats :: [Pat] -> TI ([Pred], [Assump], [Type]) 302 | tiPats pats = do psasts <- mapM tiPat pats 303 | let ps = concat [ ps' | (ps',_,_) <- psasts ] 304 | as = concat [ as' | (_,as',_) <- psasts ] 305 | ts = [ t | (_,_,t) <- psasts ] 306 | return (ps, as, ts) 307 | 308 | ----------------------------------------------------------------------------- 309 | 310 | tiExpr :: Infer Expr Type 311 | 312 | tiExpr ce env e@(Var i) = 313 | do sc_or_t <- lookupEnv env i 314 | case sc_or_t of 315 | Left sc -> do (ps :=> t) <- freshInst sc 316 | return (ps, t, foldl Ap e (map ClassPH ps)) 317 | Right t -> return ([], t, RecPH i) 318 | 319 | tiExpr ce env e@(Con con) = do (ps :=> t) <- freshInst (conScheme con) 320 | return (ps, t, e) 321 | tiExpr ce env e@(Lit l) = do (ps, t) <- tiLit l 322 | return (ps, t, e) 323 | tiExpr ce env (Ap e f) = do (ps, te, e') <- tiExpr ce env e 324 | (qs, tf, f') <- tiExpr ce env f 325 | t <- newTVar Star 326 | unify (tf `fn` t) te 327 | return (ps ++ qs, t, Ap e' f') 328 | tiExpr ce env (Let bg e) = do (ps, as, bg') <- tiBindGroup ce env bg 329 | (qs, t, e') <- tiExpr ce (extend env as) e 330 | return (ps ++ qs, t, Let bg' e') 331 | 332 | tiExpr ce env (Case e pses) = do (ps, te, e') <- tiExpr ce env e 333 | tf <- newTVar Star 334 | t <- newTVar Star 335 | unify (te `fn` t) tf 336 | (qs, alts') <- tiAlts ce env alts tf 337 | let pses' = zip (map fst pses) (map snd alts') 338 | return (ps ++ qs, t, Case e' pses') 339 | where alts = [([p], e) | (p, e) <- pses] 340 | 341 | tiExpr ce env (Lambda alt) = do (ps, t, alt') <- tiAlt ce env alt 342 | return (ps, t, Lambda alt') 343 | 344 | -- e :: sc => let v :: sc; v = e in v と変換したときと同じになってる? 345 | tiExpr ce env (ESign e sc) = 346 | do (qs :=> t) <- freshInst sc 347 | (ps, te, e') <- tiExpr ce env e 348 | unify te t 349 | s <- getSubst 350 | let qs' = apply s qs 351 | t' = apply s t 352 | fs = tv (apply s env) 353 | gs = tv t' \\ fs 354 | sc' = quantify gs (qs' :=> t') 355 | ps' = filter (not . entail ce qs') (apply s ps) 356 | (ds, rs) <- split ce fs gs ps' 357 | if sc /= sc' 358 | then fail "signature too general" 359 | else if not (null rs) 360 | then fail "context too weak" 361 | else return (ds, te, e') 362 | 363 | 364 | ----------------------------------------------------------------------------- 365 | 366 | tiAlt :: Infer Alt Type 367 | tiAlt ce env (pats, rhs) = 368 | do (ps, as, ts) <- tiPats pats 369 | (qs, t, rhs') <- tiRhs ce (extend env as) rhs 370 | return (ps ++ qs, foldr fn t ts, (pats, rhs')) 371 | 372 | tiAlts :: ClassEnv -> Env -> [Alt] -> Type -> TI ([Pred], [Alt]) 373 | tiAlts ce env alts t = do r <- mapM (tiAlt ce env) alts 374 | mapM (unify t) [t' | (_, t', _) <- r] 375 | return (concat [p | (p, _, _) <- r], 376 | [a | (_, _, a) <- r]) 377 | 378 | ----------------------------------------------------------------------------- 379 | 380 | tiRhs :: Infer Rhs Type 381 | 382 | tiRhs ce env (Rhs e) = 383 | do (ps, t, e') <- tiExpr ce env e 384 | return (ps, t, Rhs e') 385 | 386 | tiRhs ce env (Where bg rhs) = 387 | do (ps, as, bg') <- tiBindGroup ce env bg 388 | (qs, t, rhs') <- tiRhs ce (extend env as) rhs 389 | return (ps ++ qs, t, Where bg' rhs') 390 | 391 | tiRhs ce env (Guarded guards) = 392 | do t <- newTVar Star 393 | r <- mapM (tiGuard ce env) guards 394 | mapM (unify t) [t' | (_,t',_) <- r] 395 | return (concat [p | (p,_,_) <- r], t, Guarded [g| (_,_,g) <- r]) 396 | 397 | tiGuard :: Infer (Expr, Expr) Type 398 | tiGuard ce env (cond, e) = 399 | do (ps, tcond, cond') <- tiExpr ce env cond 400 | unify tcond tBool 401 | (qs, te, e') <- tiExpr ce env e 402 | return (ps ++ qs, te, (cond', e')) 403 | 404 | ----------------------------------------------------------------------------- 405 | 406 | split :: Monad m => ClassEnv -> [Tyvar] -> [Tyvar] -> [Pred] 407 | -> m ([Pred], [Pred]) 408 | split ce fs gs ps = do ps' <- reduce ce ps 409 | let (ds, rs) = partition (all (`elem` fs) . tv) ps' 410 | rs' <- defaultedPreds ce (fs++gs) rs 411 | return (ds, rs \\ rs') 412 | 413 | type Ambiguity = (Tyvar, [Pred]) 414 | 415 | ambiguities :: ClassEnv -> [Tyvar] -> [Pred] -> [Ambiguity] 416 | ambiguities ce vs ps = [ (v, filter (elem v . tv) ps) | v <- tv ps \\ vs ] 417 | 418 | numClasses :: [Id] 419 | numClasses = ["Num", "Integral", "Floating", "Fractional", 420 | "Real", "RealFloat", "RealFrac"] 421 | 422 | stdClasses :: [Id] 423 | stdClasses = ["Eq", "Ord", "Show", "Read", "Bounded", "Enum", "Ix", 424 | "Functor", "Monad", "MonadPlus"] ++ numClasses 425 | 426 | candidates :: ClassEnv -> Ambiguity -> [Type] 427 | candidates ce (v, qs) = [ t' | let is = [ i | IsIn i t <- qs ] 428 | ts = [ t | IsIn i t <- qs ], 429 | all ((TVar v)==) ts, 430 | any (`elem` numClasses) is, 431 | all (`elem` stdClasses) is, 432 | t' <- defaults ce, 433 | all (entail ce []) [ IsIn i t' | i <- is ] ] 434 | 435 | withDefaults :: Monad m => ([Ambiguity] -> [Type] -> a) 436 | -> ClassEnv -> [Tyvar] -> [Pred] -> m a 437 | withDefaults f ce vs ps 438 | | any null tss = fail "cannot resolve ambiguity" 439 | | otherwise = return (f vps (map head tss)) 440 | where vps = ambiguities ce vs ps 441 | tss = map (candidates ce) vps 442 | 443 | defaultedPreds :: Monad m => ClassEnv -> [Tyvar] -> [Pred] -> m [Pred] 444 | defaultedPreds = withDefaults (\vps ts -> concat (map snd vps)) 445 | 446 | defaultSubst :: Monad m => ClassEnv -> [Tyvar] -> [Pred] -> m Subst 447 | defaultSubst = withDefaults (\vps ts -> zip (map fst vps) ts) 448 | 449 | ----------------------------------------------------------------------------- 450 | -- Resolving Placeholders 451 | 452 | data ResolveEnv = ResolveEnv { reParam :: [(Pred, Expr)], 453 | reRec :: [(Id, Expr)], 454 | reSubst :: Subst, 455 | reClass :: ClassEnv } 456 | 457 | resolve :: ClassEnv -> Subst -> [(Id, [Pred])] -> [Pred] -> [Alt] -> [Alt] 458 | resolve ce s recs ps alts = map resolveAlt alts 459 | where dictVars = [c ++ '#' : v | IsIn c (TVar (Tyvar v _)) <- ps] 460 | env = ResolveEnv { reParam = zip ps (map Var dictVars), 461 | reRec = [(i, foldl Ap (Var i) (map ClassPH ps)) 462 | | (i, ps) <- recs], 463 | reSubst = s, 464 | reClass = ce } 465 | dictParams = map PVar dictVars 466 | resolveAlt (pats, rhs) = (dictParams ++ pats, resolveRhs env rhs) 467 | 468 | resolveRhs :: ResolveEnv -> Rhs -> Rhs 469 | resolveRhs re (Rhs e) = Rhs (resolveExpr re e) 470 | resolveRhs re (Where bg rhs) = 471 | Where (resolveBindGroup re bg) (resolveRhs re rhs) 472 | resolveRhs re (Guarded guards) = 473 | Guarded [(resolveExpr re cond, resolveExpr re e) | (cond, e) <- guards] 474 | 475 | resolveExpr :: ResolveEnv -> Expr -> Expr 476 | resolveExpr re e@(Var _) = e 477 | resolveExpr re e@(Lit _) = e 478 | resolveExpr re e@(Con _) = e 479 | resolveExpr re (Ap e f) = Ap (resolveExpr re e) (resolveExpr re f) 480 | resolveExpr re (Let bg e) = Let (resolveBindGroup re bg) (resolveExpr re e) 481 | resolveExpr re (Case e pairs) = 482 | Case (resolveExpr re e) [(p, resolveRhs re rhs) | (p, rhs) <- pairs] 483 | resolveExpr re (Lambda (pats, rhs)) = Lambda (pats, resolveRhs re rhs) 484 | resolveExpr re (ESign e sc) = ESign (resolveExpr re e) sc 485 | resolveExpr re e@(RecPH i) = case lookup i (reRec re) of 486 | Just e' -> resolveExpr re e' 487 | Nothing -> e 488 | resolveExpr re e@(ClassPH p@(IsIn _ v)) = 489 | case lookup p' (reParam re) of 490 | Just e' -> e' 491 | Nothing -> 492 | case byInst (reClass re) p' of 493 | Just (ps, e') -> foldl Ap e' (map (resolveExpr re . ClassPH) ps) 494 | Nothing -> 495 | case resolveSuper re pes p' of 496 | Just e' -> e' 497 | Nothing -> e 498 | where p' = apply (reSubst re) p 499 | pes = [pe | pe@(IsIn _ v', _) <- reParam re, v == v'] 500 | 501 | resolveSuper :: ResolveEnv -> [(Pred, Expr)] -> Pred -> Maybe Expr 502 | resolveSuper re [] p = Nothing 503 | resolveSuper re pes@(_:_) p = 504 | case lookup p pes' of 505 | Just e' -> Just e' 506 | Nothing -> resolveSuper re pes' p 507 | where pes' = [(IsIn sup v, Var (cls ++ ">>" ++ sup) `Ap` e) 508 | | (IsIn cls v, e) <- pes, sup <- super (reClass re) cls] 509 | 510 | resolveBindGroup re (es, iss) = (es', iss') 511 | where es' = [(i, sc, resolveAlts alts) | (i, sc, alts) <- es] 512 | iss' = map (\is -> [(i, resolveAlts alts) | (i, alts) <- is]) iss 513 | resolveAlts alts = [(pats, resolveRhs re rhs) | (pats, rhs) <- alts] 514 | ----------------------------------------------------------------------------- 515 | 516 | tiExpl :: ClassEnv -> Env -> Expl -> TI ([Pred], Expl) 517 | tiExpl ce env (i, sc, alts) 518 | = do (qs :=> t) <- freshInst sc 519 | (ps, alts') <- tiAlts ce env alts t 520 | s <- getSubst 521 | let qs' = apply s qs 522 | t' = apply s t 523 | fs = tv (apply s env) 524 | gs = tv t' \\ fs 525 | sc' = quantify gs (qs' :=> t') 526 | ps' = filter (not . entail ce qs') (apply s ps) 527 | alts'' = resolve ce s [] qs' alts' 528 | (ds, rs) <- split ce fs gs ps' 529 | if sc /= sc' then 530 | fail ("signature too general: expected" ++ show sc 531 | ++ ", but inferred " ++ show sc') 532 | else if not (null rs) then 533 | fail "context too weak" 534 | else 535 | return (ds, (i, sc, alts'')) 536 | 537 | ----------------------------------------------------------------------------- 538 | 539 | restricted :: [Impl] -> Bool 540 | restricted bs = any simple bs 541 | where simple (i,alts) = any (null . fst) alts 542 | 543 | tiImpls :: Infer [Impl] [Assump] 544 | tiImpls ce env [] = return ([], [], []) 545 | tiImpls ce env bs = 546 | do ts <- mapM (\_ -> newTVar Star) bs 547 | let is = map fst bs 548 | env' = extendRec env (zip is ts) 549 | altss = map snd bs 550 | pssass <- sequence (zipWith (tiAlts ce env') altss ts) 551 | s <- getSubst 552 | let ps' = apply s (concat (map fst pssass)) 553 | ts' = apply s ts 554 | fs = tv (apply s env) 555 | vss = map tv ts' 556 | gs = foldr1 union vss \\ fs 557 | (ds, rs) <- split ce fs (foldr1 intersect vss) ps' 558 | if restricted bs then 559 | let gs' = gs \\ tv rs 560 | scs = map (quantify gs' . ([] :=>)) ts' 561 | recenv = zip is (repeat []) 562 | altss' = map (resolve ce s recenv [] . snd) pssass 563 | bs' = zip is altss' 564 | in return (ds ++ rs, zipWith (:>:) is scs, bs') 565 | else 566 | let scs = map (quantify gs . (rs :=>)) ts' 567 | recenv = zip is (repeat rs) 568 | altss' = map (resolve ce s recenv rs . snd) pssass 569 | bs' = zip is altss' 570 | in return (ds, zipWith (:>:) is scs, bs') 571 | 572 | ----------------------------------------------------------------------------- 573 | 574 | tiBindGroup :: Infer BindGroup [Assump] 575 | tiBindGroup ce env (es,iss) = 576 | do let as = [ v:>:sc | (v,sc,alts) <- es ] 577 | (ps, as', iss') <- tiSeq tiImpls ce (extend env as) iss 578 | qses_s <- mapM (tiExpl ce (extend env (as'++as))) es 579 | return (ps ++ concat (map fst qses_s), as' ++ as, (map snd qses_s, iss')) 580 | 581 | tiSeq :: Infer bg [Assump] -> Infer [bg] [Assump] 582 | tiSeq ti ce env [] = return ([], [], []) 583 | tiSeq ti ce env (bs:bss) = do (ps, as, bs') <- ti ce env bs 584 | (qs, as', bss') <- tiSeq ti ce (extend env as) bss 585 | return (ps ++ qs, as' ++ as, bs':bss') 586 | 587 | 588 | -- Type Inference for Whole Programs 589 | tiProgram :: ClassEnv -> [Assump] -> Program -> ([Assump], Program) 590 | tiProgram ce as bgs = runTI $ 591 | do (ps, as', bgs') <- tiSeq tiBindGroup ce (makeEnv as) bgs 592 | s <- getSubst 593 | rs <- reduce ce (apply s ps) 594 | s' <- defaultSubst ce [] rs 595 | return (apply (s'@@s) as', bgs') 596 | 597 | ----------------------------------------------------------------------------- 598 | 599 | preludeAssumptions :: [Assump] 600 | preludeAssumptions = [ 601 | "+" :>: (toScheme (tInt `fn` tInt `fn` tInt)), 602 | "-" :>: (toScheme (tInt `fn` tInt `fn` tInt)), 603 | "*" :>: (toScheme (tInt `fn` tInt `fn` tInt)), 604 | -- "/" :>: (toScheme (tInt `fn` tInt `fn` tInt)), 605 | "div":>: (toScheme (tInt `fn` tInt `fn` tInt)), 606 | "mod":>: (toScheme (tInt `fn` tInt `fn` tInt)), 607 | -- "==" :>: (toScheme (tInt `fn` tInt `fn` tBool)), 608 | -- "eql" :>: (quantifyAll ([IsIn "Eq" a] :=> (a `fn` a `fn` tBool))), 609 | -- "/=" :>: (toScheme (tInt `fn` tInt `fn` tBool)), 610 | "<" :>: (toScheme (tInt `fn` tInt `fn` tBool)), 611 | ">" :>: (toScheme (tInt `fn` tInt `fn` tBool)), 612 | "<=" :>: (toScheme (tInt `fn` tInt `fn` tBool)), 613 | ">=" :>: (toScheme (tInt `fn` tInt `fn` tBool)), 614 | "&&" :>: (toScheme (tBool `fn` tBool `fn` tBool)), 615 | "||" :>: (toScheme (tBool `fn` tBool `fn` tBool)), 616 | "ord":>: (toScheme (tChar `fn` tInt)), 617 | "chr":>: (toScheme (tInt `fn` tChar)), 618 | "++" :>: (quantifyAll' (list a `fn` list a `fn` list a)), 619 | "." :>: (quantifyAll' ((b `fn` c) `fn` (a `fn` b) `fn` a `fn` c)), 620 | "error" :>: (quantifyAll' (list tChar `fn` a)), 621 | "hGetContents" :>: (toScheme (tInt `fn` list tChar)), 622 | "IF" :>: (quantifyAll' (tBool `fn` a `fn` a `fn` a)), 623 | "SEL" :>: (quantifyAll' (a `fn` b))] 624 | where a = TVar (Tyvar "a" Star) 625 | b = TVar (Tyvar "b" Star) 626 | c = TVar (Tyvar "c" Star) 627 | 628 | addCoreClasses :: EnvTransformer 629 | addCoreClasses = foldl1 (<:>) [ 630 | addClass "Eq" [] [ 631 | "==" :>: (quantifyAll ([IsIn "Eq" a] :=> (a `fn` a `fn` tBool))), 632 | "/=" :>: (quantifyAll ([IsIn "Eq" a] :=> (a `fn` a `fn` tBool)))], 633 | addImpls [tupleSelector "==" 0 2, tupleSelector "/=" 1 2], 634 | -- addClass "Ord" ["Eq"] [], 635 | -- addClass "Show" [] [], 636 | -- addClass "Read" [] [], 637 | -- addClass "Bounded" [] [], 638 | -- addClass "Enum" [] [], 639 | -- addClass "Functor" [] [], 640 | -- addClass "Monad" [] [], 641 | addInst [] (IsIn "Eq" tInt) (Var "EqInt"), 642 | addImpls [("EqInt", [([], Rhs $ tuple [Var "&eq", Var "&neq"])])], 643 | addInst [] (IsIn "Eq" tChar) (Var "EqChar"), 644 | addImpls [("EqChar", [([], Rhs $ tuple [Var "&eq", Var "&neq"])])] 645 | ] 646 | where a = TVar (Tyvar "a" Star) 647 | 648 | {- 649 | addNumClasses :: EnvTransformer 650 | addNumClasses = addClass "Num" ["Eq", "Show"] 651 | <:> addClass "Real" ["Num", "Ord"] 652 | <:> addClass "Fractional" ["Num"] 653 | <:> addClass "Integral" ["Real", "Enum"] 654 | <:> addClass "RealFrac" ["Real", "Fractional"] 655 | <:> addClass "Floating" ["Fractional"] 656 | <:> addClass "RealFloat" ["RealFrac", "Floating"] 657 | 658 | addPreludeClasses :: EnvTransformer 659 | addPreludeClasses = addCoreClasses <:> addNumClasses 660 | -} 661 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | all: echo.lazy even_lines.lazy hello.lazy tarai.lazy reverse_lines.lazy fizzbuzz.lazy lisp.lazy 2 | 3 | %.lazy : %.hs 4 | ../hs2lazy hs2lazy-prelude.hs $< > $@ 5 | -------------------------------------------------------------------------------- /examples/echo.hs: -------------------------------------------------------------------------------- 1 | main stdin = stdin 2 | -------------------------------------------------------------------------------- /examples/even_lines.hs: -------------------------------------------------------------------------------- 1 | evenList :: [a] -> [a] 2 | evenList [] = [] 3 | evenList [x] = [] 4 | evenList (x:y:z) = y : evenList z 5 | 6 | main = interact (unlines . evenList . lines) 7 | -------------------------------------------------------------------------------- /examples/fizzbuzz.hs: -------------------------------------------------------------------------------- 1 | fb n | mod n 15 == 0 = "FizzBuzz" 2 | | mod n 5 == 0 = "Buzz" 3 | | mod n 3 == 0 = "Fizz" 4 | | otherwise = show n 5 | 6 | fizzbuzz n | n > 100 = [] 7 | | otherwise = fb n ++ '\n' : fizzbuzz (n+1) 8 | 9 | main = putStr $ fizzbuzz 1 10 | -------------------------------------------------------------------------------- /examples/hello.hs: -------------------------------------------------------------------------------- 1 | main = putStr "Hello, world!\n" 2 | -------------------------------------------------------------------------------- /examples/hs2lazy-prelude.hs: -------------------------------------------------------------------------------- 1 | --*- haskell -*- 2 | data Maybe a = Nothing | Just a 3 | data Ordering = LT | EQ | GT 4 | 5 | type ShowS = String -> String 6 | 7 | class Show a where 8 | showsPrec :: Int -> a -> ShowS 9 | show :: a -> String 10 | 11 | showsPrec _ x s = show x ++ s 12 | show x = showsPrec 0 x "" 13 | 14 | instance Show Int where 15 | showsPrec p n = if n < 0 16 | then showChar '-' . shows (0-n) 17 | else let d = chr (ord '0' + mod n 10) 18 | m = div n 10 19 | in if m == 0 20 | then showChar d 21 | else showsPrec p m . showChar d 22 | 23 | instance Eq a => Eq [a] where 24 | (==) [] [] = True 25 | (==) [] _ = False 26 | (==) _ [] = False 27 | (==) (x:xs) (y:ys) = x == y && xs == ys 28 | (/=) xs ys = not (xs == ys) 29 | 30 | shows :: (Show a) => a -> ShowS 31 | shows = showsPrec 0 32 | 33 | showChar :: Char -> ShowS 34 | showChar = (:) 35 | 36 | showString :: String -> ShowS 37 | showString = (++) 38 | 39 | 40 | ($) :: (a -> b) -> a -> b 41 | ($) f x = f x 42 | 43 | fst :: (a, b) -> a 44 | fst (a, b) = a 45 | 46 | snd :: (a, b) -> b 47 | snd (a, b) = b 48 | 49 | map :: (a -> b) -> [a] -> [b] 50 | map f (x:xs) = f x : map f xs 51 | map f [] = [] 52 | 53 | filter :: (a -> Bool) -> [a] -> [a] 54 | filter p [] = [] 55 | filter p (x:xs) = if p x 56 | then x : filter p xs 57 | else filter p xs 58 | 59 | null :: [a] -> Bool 60 | null [] = True 61 | null (_:_) = False 62 | 63 | head :: [a] -> a 64 | head [] = error "head []" 65 | head (x:xs) = x 66 | 67 | tail :: [a] -> [a] 68 | tail [] = error "tail []" 69 | tail (x:xs) = xs 70 | 71 | last :: [a] -> a 72 | last [x] = x 73 | last (_:xs) = last xs 74 | last [] = error "Prelude.last: empty list" 75 | 76 | init :: [a] -> [a] 77 | init [x] = [] 78 | init (x:xs) = x : init xs 79 | init [] = error "Prelude.init: empty list" 80 | 81 | length :: [a] -> Int 82 | length [] = 0 83 | length (_:l) = 1 + length l 84 | 85 | reverse :: [a] -> [a] 86 | reverse = foldl (\x y -> y : x) [] 87 | 88 | concat :: [[a]] -> [a] 89 | concat xss = foldr (++) [] xss 90 | 91 | concatMap :: (a -> [b]) -> [a] -> [b] 92 | concatMap f = concat . map f 93 | 94 | drop :: Int -> [a] -> [a] 95 | drop 0 xs = xs 96 | drop _ [] = [] 97 | drop n (_:xs) = drop (n-1) xs 98 | 99 | isDigit, isUpper, isLower :: Char -> Bool 100 | isDigit c = let { o = ord c } in o >= ord '0' && o <= ord '9' 101 | isUpper c = let { o = ord c } in o >= ord 'A' && o <= ord 'Z' 102 | isLower c = let { o = ord c } in o >= ord 'a' && o <= ord 'z' 103 | 104 | and, or :: [Bool] -> Bool 105 | and = foldr (&&) True 106 | or = foldr (||) False 107 | 108 | foldl :: (a -> b -> a) -> a -> [b] -> a 109 | foldl f z [] = z 110 | foldl f z (x:xs) = foldl f (f z x) xs 111 | 112 | foldr :: (a -> b -> b) -> b -> [a] -> b 113 | foldr f z xs = if null xs 114 | then z 115 | else f (head xs) (foldr f z (tail xs)) 116 | 117 | elem :: Eq a => a -> [a] -> Bool 118 | elem e [] = False 119 | elem e (x:xs) = e == x || elem e xs 120 | 121 | lookup :: Eq a => a -> [(a, b)] -> Maybe b 122 | lookup x ((key, val) : ys) = if x == key then Just val else lookup x ys 123 | lookup x [] = Nothing 124 | 125 | compare :: Int -> Int -> Ordering 126 | compare x y = if x == y then EQ else if x <= y then LT else GT 127 | 128 | repeat :: a -> [a] 129 | repeat x = let { xs = x:xs } in xs 130 | 131 | not :: Bool -> Bool 132 | not True = False 133 | not False = True 134 | 135 | zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] 136 | zipWith z (a:as) (b:bs) = z a b : zipWith z as bs 137 | zipWith _ _ _ = [] 138 | 139 | span, break :: (a -> Bool) -> [a] -> ([a],[a]) 140 | span p [] = ([],[]) 141 | span p xs@(x:xs') = if p x 142 | then case span p xs' of 143 | (ys, zs) -> (x:ys,zs) 144 | else ([], xs) 145 | break p = span (not . p) 146 | 147 | le :: String -> String -> Bool 148 | le [] _ = True 149 | le _ [] = False 150 | le (x:xs) (y:ys) = case compare (ord x) (ord y) of 151 | LT -> True 152 | EQ -> le xs ys 153 | GT -> False 154 | 155 | lines :: String -> [String] 156 | lines [] = [] 157 | lines s = case break ((==) '\n') s of 158 | (l, s') -> l : case s' of 159 | [] -> [] 160 | (_:s'') -> lines s'' 161 | 162 | unlines :: [String] -> String 163 | unlines = concatMap (\s -> s ++ "\n") 164 | 165 | listToMaybe :: [a] -> Maybe a 166 | listToMaybe [] = Nothing 167 | listToMaybe (a:_) = Just a 168 | 169 | find :: (a -> Bool) -> [a] -> Maybe a 170 | find p = listToMaybe . filter p 171 | 172 | otherwise :: Bool 173 | otherwise = True 174 | 175 | 176 | data Stream = Stream Char Stream 177 | 178 | eof = chr 256 179 | 180 | fromStream :: Stream -> String 181 | fromStream (Stream c cs) = if 256 <= ord c then [] else c : fromStream cs 182 | 183 | toStream :: String -> Stream 184 | toStream [] = Stream '\n' $ Stream eof (toStream []) 185 | toStream (c:cs) = Stream c (toStream cs) 186 | 187 | putStr :: String -> Stream -> Stream 188 | putStr s _ = toStream s 189 | 190 | interact :: (String -> String) -> Stream -> Stream 191 | interact f = toStream . f . fromStream 192 | 193 | 194 | -- Mock IO operations 195 | (>>) :: a -> b -> b 196 | (>>) x y = y 197 | hSetBuffering x y = x 198 | stdout = 1 199 | data Buffering = NoBuffering 200 | -------------------------------------------------------------------------------- /examples/lisp.hs: -------------------------------------------------------------------------------- 1 | -- Tiny lisp interpreter (https://github.com/irori/lazyk-lisp) 2 | 3 | -- hs2lazy ignores import declarations 4 | import Prelude hiding (read, readList) 5 | import Data.Char (ord, isDigit) 6 | import System.IO 7 | 8 | ------------------ 9 | -- Lisp Objects -- 10 | ------------------ 11 | data Object = Cons Object Object 12 | | Number Int 13 | | Symbol String 14 | | Proc ([Object] -> Global -> (Object, Global)) 15 | 16 | instance Show Object where 17 | showsPrec 0 (Cons hd tl) = showChar '(' . showsPrec 0 hd . showsPrec 1 tl 18 | showsPrec 0 (Number n) = showsPrec 0 n 19 | showsPrec 0 (Proc _) = showString "" 20 | showsPrec 0 (Symbol s) = showString s 21 | showsPrec 1 (Cons hd tl) = showChar ' ' . showsPrec 0 hd . showsPrec 1 tl 22 | showsPrec 1 (Symbol "nil") = showChar ')' 23 | showsPrec 1 a = showString " . " . showsPrec 0 a . showChar ')' 24 | 25 | atomQuote = Symbol "quote" 26 | atomNil = Symbol "nil" 27 | atomT = Symbol "t" 28 | 29 | isTrue :: Object -> Bool 30 | isTrue (Symbol s) = s /= "nil" 31 | isTrue _ = True 32 | 33 | eq (Number n1) (Number n2) = n1 == n2 34 | eq (Symbol s1) (Symbol s2) = s1 == s2 35 | eq _ _ = False 36 | 37 | list :: [Object] -> Object 38 | list = foldr Cons atomNil 39 | 40 | ------------ 41 | -- Reader -- 42 | ------------ 43 | read :: String -> (Object, String) 44 | read (' ':s) = read s 45 | read ('\n':s) = read s 46 | read ('(':s) = readList [] s 47 | read ('\'':s) = case read s of 48 | (o, s') -> (list [atomQuote, o], s') 49 | read s = case span isDigit s of 50 | ([], _) -> case break (\c -> elem c " \n()") s of 51 | (sym, s') -> (Symbol sym, s') 52 | (digits, s') -> (Number $ parseInt 0 digits, s') 53 | 54 | readList :: [Object] -> String -> (Object, String) 55 | readList os (')':s) = (list (reverse os), s) 56 | readList os s = case read s of 57 | (o, s') -> readList (o:os) s' 58 | 59 | parseInt :: Int -> String -> Int 60 | parseInt a [] = a 61 | parseInt a (d:ds) = parseInt (a * 10 + ord d - ord '0') ds 62 | 63 | ------------------ 64 | -- Global State -- 65 | ------------------ 66 | type Global = (Maybe Error, DynamicVars) 67 | type Error = String 68 | type DynamicVars = [(String, Object)] 69 | 70 | initialGlobal :: Global 71 | initialGlobal = (Nothing, [("set", Proc primSet) 72 | ,("nil", atomNil) 73 | ,("cons", Proc primCons) 74 | ,("car", Proc primCar) 75 | ,("cdr", Proc primCdr) 76 | ,("atom", Proc primAtom) 77 | ,("eq", Proc primEq) 78 | ,("+", Proc primPlus) 79 | ,("-", Proc primMinus) 80 | ,("*", Proc primTimes) 81 | ,("/", Proc primDivide) 82 | ,("mod", Proc primMod) 83 | ]) 84 | 85 | updateDynamic :: Global -> String -> Object -> Global 86 | updateDynamic (err, (v, o) : gvars) var val = 87 | if v == var 88 | then (err, (var, val) : gvars) 89 | else (err, (var, val) : (v, o) : gvars) 90 | 91 | ----------------- 92 | -- Environment -- 93 | ----------------- 94 | type Env = String -> Maybe Object 95 | 96 | initialEnv :: Env 97 | initialEnv v = Nothing 98 | 99 | extendEnv :: Object -> [Object] -> Env -> Env 100 | extendEnv (Cons (Symbol var) vars) (arg:args) env = 101 | \v -> if v == var then Just arg else extendEnv vars args env v 102 | extendEnv _ _ env = env 103 | -- FIXME: error if length vars /= length args 104 | 105 | makeProcedure :: Object -> Object -> Env -> Object 106 | makeProcedure vars body env = 107 | Proc (\args glo -> eval (extendEnv vars args env) glo body) 108 | 109 | --------------- 110 | -- Evaluator -- 111 | --------------- 112 | errExit :: String -> (Object, Global) 113 | errExit msg = (atomNil, (Just msg, [])) 114 | 115 | apply :: Object -> [Object] -> Global -> (Object, Global) 116 | apply (Proc proc) args glo = proc args glo 117 | apply _ _ _ = errExit "apply: unknown procedure type" 118 | 119 | eval :: Env -> Global -> Object -> (Object, Global) 120 | eval env glo e@(Number _) = (e, glo) 121 | 122 | eval env glo@(_, gvars) (Symbol v) = 123 | case env v of 124 | Just obj -> (obj, glo) 125 | Nothing -> case lookup v gvars of 126 | Just obj -> (obj, glo) 127 | Nothing -> errExit ("unbound variable " ++ v) 128 | 129 | eval env glo (Cons (Symbol "lambda") (Cons vars (Cons body _))) = 130 | (makeProcedure vars body env, glo) 131 | 132 | eval env glo (Cons (Symbol "quote") (Cons obj _)) = (obj, glo) 133 | 134 | eval env glo (Cons (Symbol "if") (Cons e1 (Cons e2 (Cons e3 _)))) = 135 | case eval env glo e1 of 136 | (v, glo') -> eval env glo' (if isTrue v then e2 else e3) 137 | 138 | eval env glo e@(Cons _ _) = 139 | case evalArgs env glo e [] of 140 | (op:args, glo') -> apply op args glo' 141 | 142 | evalArgs :: Env -> Global -> Object -> [Object] -> ([Object], Global) 143 | evalArgs env glo (Cons e es) args = 144 | case eval env glo e of (arg, glo') -> evalArgs env glo' es (arg:args) 145 | evalArgs _ glo _ args = (reverse args, glo) 146 | 147 | ----------------------- 148 | -- Builtin Functions -- 149 | ----------------------- 150 | type Builtin = [Object] -> Global -> (Object, Global) 151 | primSet :: Builtin 152 | primSet (Symbol var : val : []) glo = (val, updateDynamic glo var val) 153 | primSet _ glo = errExit "set: invalid argument" 154 | 155 | primCons :: Builtin 156 | primCons (e1:e2:[]) glo = (Cons e1 e2, glo) 157 | primCons _ glo = errExit "cons: invalid argument" 158 | 159 | primCar :: Builtin 160 | primCar ((Cons a _):[]) glo = (a, glo) 161 | primCar _ glo = errExit "car: invalid argument" 162 | 163 | primCdr :: Builtin 164 | primCdr ((Cons _ b):[]) glo = (b, glo) 165 | primCdr _ glo = errExit "cdr: invalid argument" 166 | 167 | primAtom :: Builtin 168 | primAtom ((Cons _ _):_) glo = (atomNil, glo) 169 | primAtom _ glo = (atomT, glo) 170 | 171 | primEq :: Builtin 172 | primEq (e1:e2:[]) glo = (if eq e1 e2 then atomT else atomNil, glo) 173 | primEq _ glo = errExit "eq: invalid argument" 174 | 175 | primPlus :: Builtin 176 | primPlus (Number n : Number m : []) glo = (Number (n+m), glo) 177 | primPlus _ glo = errExit "+: invalid argument" 178 | 179 | primMinus :: Builtin 180 | primMinus (Number n : Number m : []) glo = (Number (n-m), glo) 181 | primMinus _ glo = errExit "-: invalid argument" 182 | 183 | primTimes :: Builtin 184 | primTimes (Number n : Number m : []) glo = (Number (n*m), glo) 185 | primTimes _ glo = errExit "*: invalid argument" 186 | 187 | primDivide :: Builtin 188 | primDivide (Number n : Number 0 : []) glo = errExit "/: division by zero" 189 | primDivide (Number n : Number m : []) glo = (Number (div n m), glo) 190 | primDivide _ glo = errExit "/: invalid argument" 191 | 192 | primMod :: Builtin 193 | primMod (Number n : Number 0 : []) glo = errExit "mod: division by zero" 194 | primMod (Number n : Number m : []) glo = (Number (mod n m), glo) 195 | primMod _ glo = errExit "mod: invalid argument" 196 | 197 | ---------- 198 | -- REPL -- 199 | ---------- 200 | defun :: Global -> String -> Object -> Object -> Global 201 | defun (err, gvars) name vars body = 202 | (err, (name, makeProcedure vars body initialEnv) : gvars) 203 | 204 | repl :: Global -> String -> ShowS 205 | repl glo input = showString "> " . 206 | case read input of 207 | (Cons (Symbol "defun") (Cons (Symbol name) (Cons vars (Cons body _))), input') -> 208 | showString name . showChar '\n' . repl (defun glo name vars body) input' 209 | (Symbol "", []) -> (\x -> x) -- End of input 210 | (e, input') -> 211 | case eval initialEnv glo e of 212 | (_, (Just errmsg, _)) -> showString errmsg . showChar '\n' . repl glo input' 213 | (r, glo') -> shows r . showChar '\n' . repl glo' input' 214 | 215 | main = hSetBuffering stdout NoBuffering >> 216 | interact (\s -> repl initialGlobal s "") 217 | -------------------------------------------------------------------------------- /examples/reverse_lines.hs: -------------------------------------------------------------------------------- 1 | main = interact (unlines . reverse . lines) 2 | -------------------------------------------------------------------------------- /examples/tarai.hs: -------------------------------------------------------------------------------- 1 | tarai :: Int -> Int -> Int -> Int 2 | tarai x y z 3 | | x <= y = y 4 | | otherwise = tarai (tarai (x-1) y z) 5 | (tarai (y-1) z x) 6 | (tarai (z-1) x y) 7 | 8 | main = putStr $ show $ tarai 122 52 10 9 | --------------------------------------------------------------------------------