From 00645ddd725ba3d464050df9e7a81ecd5681d60a Mon Sep 17 00:00:00 2001 From: frog-da <84839431+frog-da@users.noreply.github.com> Date: Wed, 28 Aug 2024 17:51:36 +0300 Subject: [PATCH 1/8] Abs error --- grammar/hindley-milner.cf | 3 + src/HM/Parser/Abs.hs | 4 +- src/HM/Parser/Doc.txt | 7 +- src/HM/Parser/Lex.hs | 777 +++++++++++++++++++++++--------------- src/HM/Parser/Lex.x | 14 +- src/HM/Parser/Par.hs | 578 +++++++++++++++++----------- src/HM/Parser/Par.y | 33 +- src/HM/Parser/Print.hs | 3 + src/HM/Parser/Skel.hs | 3 + src/HM/Typecheck.hs | 29 +- 10 files changed, 896 insertions(+), 555 deletions(-) diff --git a/grammar/hindley-milner.cf b/grammar/hindley-milner.cf index fbfe541..06acff4 100644 --- a/grammar/hindley-milner.cf +++ b/grammar/hindley-milner.cf @@ -10,6 +10,8 @@ EIf. Exp1 ::= "if" Exp1 "then" Exp1 "else" Exp1 ; EIsZero. Exp2 ::= "iszero" "(" Exp ")" ; ETyped. Exp ::= Exp1 ":" Type ; ELet. Exp1 ::= "let" Pattern "=" Exp1 "in" ScopedExp ; +EAbs. Exp1 ::= "λ" Ident ":" Type "." Exp1 ; +EApp. Exp1 ::= Exp1 Type Exp1 ; ScopedExp. ScopedExp ::= Exp1 ; @@ -18,3 +20,4 @@ coercions Exp 3 ; TNat. Type ::= "Nat" ; TBool. Type ::= "Bool" ; +TArrow. Type ::= Type "->" Type ; diff --git a/src/HM/Parser/Abs.hs b/src/HM/Parser/Abs.hs index 844d965..7b75166 100644 --- a/src/HM/Parser/Abs.hs +++ b/src/HM/Parser/Abs.hs @@ -29,12 +29,14 @@ data Exp | EIsZero Exp | ETyped Exp Type | ELet Pattern Exp ScopedExp + | EAbs Ident Type Exp + | EApp Exp Type Exp deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data ScopedExp = ScopedExp Exp deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) -data Type = TNat | TBool +data Type = TNat | TBool | TArrow Type Type deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) newtype Ident = Ident String diff --git a/src/HM/Parser/Doc.txt b/src/HM/Parser/Doc.txt index b0f2f3f..85f2805 100644 --- a/src/HM/Parser/Doc.txt +++ b/src/HM/Parser/Doc.txt @@ -27,11 +27,11 @@ The set of reserved words is the set of terminals appearing in the grammar. Thos The reserved words used in Parser are the following: | ``Bool`` | ``Nat`` | ``else`` | ``false`` | ``if`` | ``in`` | ``iszero`` | ``let`` - | ``then`` | ``true`` | | + | ``then`` | ``true`` | ``λ`` | The symbols used in Parser are the following: | + | - | ( | ) - | : | = | | + | : | = | . | -> ===Comments=== There are no single-line comments in the grammar.There are no multiple-line comments in the grammar. @@ -54,12 +54,15 @@ All other symbols are terminals. | | **|** | //Exp3// | //Exp1// | -> | ``if`` //Exp1// ``then`` //Exp1// ``else`` //Exp1// | | **|** | ``let`` //Pattern// ``=`` //Exp1// ``in`` //ScopedExp// + | | **|** | ``λ`` //Ident// ``:`` //Type// ``.`` //Exp1// + | | **|** | //Exp1// //Type// //Exp1// | | **|** | //Exp2// | //Exp// | -> | //Exp1// ``:`` //Type// | | **|** | //Exp1// | //ScopedExp// | -> | //Exp1// | //Type// | -> | ``Nat`` | | **|** | ``Bool`` + | | **|** | //Type// ``->`` //Type// diff --git a/src/HM/Parser/Lex.hs b/src/HM/Parser/Lex.hs index e0a9405..27ac67c 100644 --- a/src/HM/Parser/Lex.hs +++ b/src/HM/Parser/Lex.hs @@ -22,23 +22,179 @@ import qualified Data.Array alex_tab_size :: Int alex_tab_size = 8 alex_base :: Data.Array.Array Int Int -alex_base = Data.Array.listArray (0 :: Int, 5) +alex_base = Data.Array.listArray (0 :: Int, 7) [ -8 + , 140 , -42 - , 91 + , -46 + , -13 + , 171 , 0 - , 7 - , 86 + , -170 ] alex_table :: Data.Array.Array Int Int -alex_table = Data.Array.listArray (0 :: Int, 346) +alex_table = Data.Array.listArray (0 :: Int, 426) [ 0 - , 4 - , 4 - , 4 - , 4 - , 4 + , 5 + , 5 + , 5 + , 5 + , 5 + , 2 + , 2 + , 2 + , 2 + , 2 + , 2 + , 2 + , 2 + , 2 + , 2 + , 6 + , 6 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 5 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 6 + , 6 + , 0 + , 6 + , 0 + , 3 + , 6 + , 0 + , 2 + , 2 + , 2 + , 2 + , 2 + , 2 + , 2 + , 2 + , 2 + , 2 + , 6 + , 0 + , 0 + , 6 + , 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 + , 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 + , 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 @@ -49,30 +205,73 @@ alex_table = Data.Array.listArray (0 :: Int, 346) , 1 , 1 , 1 - , 4 - , 4 - , 4 - , 4 - , 4 , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 5 + , 5 + , 5 + , 5 + , 5 , 0 , 0 , 4 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 7 , 0 , 0 , 0 , 0 + , 5 , 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 , 0 , 0 - , 3 - , 3 , 0 - , 3 , 0 - , 3 + , 1 , 0 - , 4 , 1 , 1 , 1 @@ -83,71 +282,33 @@ alex_table = Data.Array.listArray (0 :: Int, 346) , 1 , 1 , 1 - , 3 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 , 0 , 0 - , 3 , 0 , 0 , 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 , 0 , 0 , 0 , 0 , 0 , 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 , 0 , 0 , 0 @@ -163,7 +324,6 @@ alex_table = Data.Array.listArray (0 :: Int, 346) , 0 , 0 , 0 - , 2 , 0 , 0 , 0 @@ -172,16 +332,6 @@ alex_table = Data.Array.listArray (0 :: Int, 346) , 0 , 0 , 0 - , 2 - , 2 - , 2 - , 2 - , 2 - , 2 - , 2 - , 2 - , 2 - , 2 , 0 , 0 , 0 @@ -189,128 +339,12 @@ alex_table = Data.Array.listArray (0 :: Int, 346) , 0 , 0 , 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 , 0 , 0 , 0 , 0 - , 2 - , 5 - , 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 , 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 , 0 - , 2 - , 2 - , 2 - , 2 - , 2 - , 2 - , 2 - , 2 , 0 , 0 , 0 @@ -319,7 +353,55 @@ alex_table = Data.Array.listArray (0 :: Int, 346) , 0 , 0 , 0 - , 5 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 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 @@ -383,7 +465,7 @@ alex_table = Data.Array.listArray (0 :: Int, 346) ] alex_check :: Data.Array.Array Int Int -alex_check = Data.Array.listArray (0 :: Int, 346) +alex_check = Data.Array.listArray (0 :: Int, 426) [ -1 , 9 , 10 @@ -400,11 +482,11 @@ alex_check = Data.Array.listArray (0 :: Int, 346) , 55 , 56 , 57 - , 9 - , 10 - , 11 - , 12 - , 13 + , 62 + , 187 + , -1 + , -1 + , -1 , -1 , -1 , -1 @@ -422,8 +504,8 @@ alex_check = Data.Array.listArray (0 :: Int, 346) , 43 , -1 , 45 + , 46 , -1 - , 32 , 48 , 49 , 50 @@ -499,30 +581,79 @@ alex_check = Data.Array.listArray (0 :: Int, 346) , 120 , 121 , 122 + , 128 + , 129 + , 130 + , 131 + , 132 + , 133 + , 134 + , 135 + , 136 + , 137 + , 138 + , 139 + , 140 + , 141 + , 142 + , 143 + , 144 + , 145 + , 146 + , 147 + , 148 + , 149 + , 150 , -1 + , 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 , -1 - , -1 - , -1 - , -1 - , -1 - , -1 - , -1 - , -1 - , -1 - , -1 - , -1 - , -1 - , -1 - , -1 + , 184 + , 185 + , 186 + , 187 + , 188 + , 189 + , 190 + , 191 , 39 + , 9 + , 10 + , 11 + , 12 + , 13 , -1 , -1 - , -1 - , -1 - , -1 - , -1 - , -1 - , -1 + , 195 , 48 , 49 , 50 @@ -533,12 +664,12 @@ alex_check = Data.Array.listArray (0 :: Int, 346) , 55 , 56 , 57 + , 206 , -1 , -1 , -1 , -1 - , -1 - , -1 + , 32 , -1 , 65 , 66 @@ -571,7 +702,7 @@ alex_check = Data.Array.listArray (0 :: Int, 346) , -1 , -1 , 95 - , 195 + , -1 , 97 , 98 , 99 @@ -598,70 +729,70 @@ alex_check = Data.Array.listArray (0 :: Int, 346) , 120 , 121 , 122 - , 128 - , 129 - , 130 - , 131 - , 132 - , 133 - , 134 - , 135 - , 136 - , 137 - , 138 - , 139 - , 140 - , 141 - , 142 - , 143 - , 144 - , 145 - , 146 - , 147 - , 148 - , 149 - , 150 , -1 - , 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 , -1 - , 184 - , 185 - , 186 - , 187 - , 188 - , 189 - , 190 - , 191 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 , -1 , -1 , -1 @@ -731,30 +862,66 @@ alex_check = Data.Array.listArray (0 :: Int, 346) , -1 , -1 , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 + , -1 ] alex_deflt :: Data.Array.Array Int Int -alex_deflt = Data.Array.listArray (0 :: Int, 5) +alex_deflt = Data.Array.listArray (0 :: Int, 7) [ -1 , -1 , -1 , -1 , -1 , -1 + , -1 + , -1 ] -alex_accept = Data.Array.listArray (0 :: Int, 5) +alex_accept = Data.Array.listArray (0 :: Int, 7) [ AlexAccNone + , AlexAcc 3 , AlexAcc 2 , AlexAcc 1 - , AlexAcc 0 + , AlexAccNone , AlexAccSkip + , AlexAcc 0 , AlexAccNone ] -alex_actions = Data.Array.array (0 :: Int, 3) - [ (2,alex_action_3) - , (1,alex_action_2) +alex_actions = Data.Array.array (0 :: Int, 4) + [ (3,alex_action_2) + , (2,alex_action_3) + , (1,alex_action_1) , (0,alex_action_1) ] @@ -1095,13 +1262,13 @@ eitherResIdent tv s = treeFind resWords -- | The keywords and symbols of the language organized as binary search tree. resWords :: BTree resWords = - b "else" 9 - (b ":" 5 + b "Nat" 10 + (b "->" 5 (b "+" 3 (b ")" 2 (b "(" 1 N N) N) (b "-" 4 N N)) - (b "Bool" 7 (b "=" 6 N N) (b "Nat" 8 N N))) - (b "iszero" 13 - (b "if" 11 (b "false" 10 N N) (b "in" 12 N N)) - (b "then" 15 (b "let" 14 N N) (b "true" 16 N N))) + (b "=" 8 (b ":" 7 (b "." 6 N N) N) (b "Bool" 9 N N))) + (b "iszero" 15 + (b "if" 13 (b "false" 12 (b "else" 11 N N) N) (b "in" 14 N N)) + (b "true" 18 (b "then" 17 (b "let" 16 N N) N) (b "\955" 19 N N))) where b s n = B bs (TS bs n) where diff --git a/src/HM/Parser/Lex.x b/src/HM/Parser/Lex.x index 6d8c3be..885ea45 100644 --- a/src/HM/Parser/Lex.x +++ b/src/HM/Parser/Lex.x @@ -28,7 +28,7 @@ $u = [. \n] -- universal: any character -- Symbols and non-identifier-like reserved words -@rsyms = \+ | \- | \( | \) | \: | \= +@rsyms = \λ | \+ | \- | \( | \) | \: | \= | \. | \- \> :- @@ -148,13 +148,13 @@ eitherResIdent tv s = treeFind resWords -- | The keywords and symbols of the language organized as binary search tree. resWords :: BTree resWords = - b "else" 9 - (b ":" 5 + b "Nat" 10 + (b "->" 5 (b "+" 3 (b ")" 2 (b "(" 1 N N) N) (b "-" 4 N N)) - (b "Bool" 7 (b "=" 6 N N) (b "Nat" 8 N N))) - (b "iszero" 13 - (b "if" 11 (b "false" 10 N N) (b "in" 12 N N)) - (b "then" 15 (b "let" 14 N N) (b "true" 16 N N))) + (b "=" 8 (b ":" 7 (b "." 6 N N) N) (b "Bool" 9 N N))) + (b "iszero" 15 + (b "if" 13 (b "false" 12 (b "else" 11 N N) N) (b "in" 14 N N)) + (b "true" 18 (b "then" 17 (b "let" 16 N N) N) (b "\955" 19 N N))) where b s n = B bs (TS bs n) where diff --git a/src/HM/Parser/Par.hs b/src/HM/Parser/Par.hs index c574ef0..7145e31 100644 --- a/src/HM/Parser/Par.hs +++ b/src/HM/Parser/Par.hs @@ -102,7 +102,17 @@ action_0, action_49, action_50, action_51, - action_52 :: () => Prelude.Int -> ({-HappyReduction (Err) = -} + action_52, + action_53, + action_54, + action_55, + action_56, + action_57, + action_58, + action_59, + action_60, + action_61, + action_62 :: () => Prelude.Int -> ({-HappyReduction (Err) = -} Prelude.Int -> (Token) -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) @@ -129,7 +139,10 @@ happyReduce_7, happyReduce_23, happyReduce_24, happyReduce_25, - happyReduce_26 :: () => ({-HappyReduction (Err) = -} + happyReduce_26, + happyReduce_27, + happyReduce_28, + happyReduce_29 :: () => ({-HappyReduction (Err) = -} Prelude.Int -> (Token) -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) @@ -138,88 +151,91 @@ happyReduce_7, -> [(Token)] -> (Err) HappyAbsSyn) happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int -happyExpList = Happy_Data_Array.listArray (0,134) ([0,0,4,128,449,4096,14624,0,27650,7,32832,237,2048,7600,0,192,0,0,32,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,32768,1,0,0,0,0,0,4096,15200,0,0,0,32832,237,2048,0,0,0,1,0,0,0,0,0,8,0,0,0,0,0,0,3,0,0,0,0,0,0,0,0,2052,14,128,449,0,12,0,64,0,32832,237,0,512,0,2,0,0,0,1024,3800,0,1,0,24592,59,0,0,0,0,0,0,0,0,8,0,0,0,1024,0,128,475,4096,15200,0,0,0,0,0,0 +happyExpList = Happy_Data_Array.listArray (0,184) ([0,0,32,1024,26656,0,8196,105,1024,31584,0,24580,123,1024,31584,0,3072,0,0,8192,0,0,0,16384,0,0,0,0,0,0,0,0,0,0,0,0,0,0,12288,0,0,0,0,0,0,0,24580,123,0,0,0,24580,123,1024,0,0,0,32,0,0,0,0,32,0,0,0,3328,0,0,0,0,3072,0,12288,0,0,0,0,0,0,0,0,0,1024,26656,0,8196,104,17408,31584,0,3072,0,0,1,0,512,0,1024,31584,0,3072,4,2048,0,0,3072,0,0,0,0,0,0,1024,31584,0,8,0,1024,31584,0,3072,0,16384,0,0,0,0,0,0,0,0,0,49152,0,0,35840,0,0,0,0,7168,0,1024,31584,0,24580,123,1024,31584,0,0,0,0,0,0,0,0,0 ]) {-# NOINLINE happyExpListPerState #-} happyExpListPerState st = token_strs_expected - where token_strs = ["error","%dummy","%start_pPattern","%start_pExp3","%start_pExp2","%start_pExp1","%start_pExp","%start_pScopedExp","%start_pType","Ident","Integer","Pattern","Exp3","Exp2","Exp1","Exp","ScopedExp","Type","'('","')'","'+'","'-'","':'","'='","'Bool'","'Nat'","'else'","'false'","'if'","'in'","'iszero'","'let'","'then'","'true'","L_Ident","L_integ","%eof"] - bit_start = st Prelude.* 37 - bit_end = (st Prelude.+ 1) Prelude.* 37 + where token_strs = ["error","%dummy","%start_pPattern","%start_pExp3","%start_pExp2","%start_pExp1","%start_pExp","%start_pScopedExp","%start_pType","Ident","Integer","Pattern","Exp3","Exp2","Exp1","Exp","ScopedExp","Type","'('","')'","'+'","'-'","'->'","'.'","':'","'='","'Bool'","'Nat'","'else'","'false'","'if'","'in'","'iszero'","'let'","'then'","'true'","'\955'","L_Ident","L_integ","%eof"] + bit_start = st Prelude.* 40 + bit_end = (st Prelude.+ 1) Prelude.* 40 read_bit = readArrayBit happyExpList bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] - bits_indexed = Prelude.zip bits [0..36] + bits_indexed = Prelude.zip bits [0..39] token_strs_expected = Prelude.concatMap f bits_indexed f (Prelude.False, _) = [] f (Prelude.True, nr) = [token_strs Prelude.!! nr] -action_0 (35) = happyShift action_8 -action_0 (10) = happyGoto action_30 -action_0 (12) = happyGoto action_31 +action_0 (38) = happyShift action_8 +action_0 (10) = happyGoto action_31 +action_0 (12) = happyGoto action_32 action_0 _ = happyFail (happyExpListPerState 0) action_1 (19) = happyShift action_18 -action_1 (28) = happyShift action_19 -action_1 (34) = happyShift action_23 -action_1 (35) = happyShift action_8 -action_1 (36) = happyShift action_24 +action_1 (30) = happyShift action_19 +action_1 (36) = happyShift action_23 +action_1 (38) = happyShift action_8 +action_1 (39) = happyShift action_25 action_1 (10) = happyGoto action_12 action_1 (11) = happyGoto action_13 -action_1 (13) = happyGoto action_29 +action_1 (13) = happyGoto action_30 action_1 _ = happyFail (happyExpListPerState 1) action_2 (19) = happyShift action_18 -action_2 (28) = happyShift action_19 -action_2 (31) = happyShift action_21 -action_2 (34) = happyShift action_23 -action_2 (35) = happyShift action_8 -action_2 (36) = happyShift action_24 +action_2 (30) = happyShift action_19 +action_2 (33) = happyShift action_21 +action_2 (36) = happyShift action_23 +action_2 (38) = happyShift action_8 +action_2 (39) = happyShift action_25 action_2 (10) = happyGoto action_12 action_2 (11) = happyGoto action_13 action_2 (13) = happyGoto action_14 -action_2 (14) = happyGoto action_28 +action_2 (14) = happyGoto action_29 action_2 _ = happyFail (happyExpListPerState 2) action_3 (19) = happyShift action_18 -action_3 (28) = happyShift action_19 -action_3 (29) = happyShift action_20 -action_3 (31) = happyShift action_21 -action_3 (32) = happyShift action_22 -action_3 (34) = happyShift action_23 -action_3 (35) = happyShift action_8 -action_3 (36) = happyShift action_24 +action_3 (30) = happyShift action_19 +action_3 (31) = happyShift action_20 +action_3 (33) = happyShift action_21 +action_3 (34) = happyShift action_22 +action_3 (36) = happyShift action_23 +action_3 (37) = happyShift action_24 +action_3 (38) = happyShift action_8 +action_3 (39) = happyShift action_25 action_3 (10) = happyGoto action_12 action_3 (11) = happyGoto action_13 action_3 (13) = happyGoto action_14 action_3 (14) = happyGoto action_15 -action_3 (15) = happyGoto action_27 +action_3 (15) = happyGoto action_28 action_3 _ = happyFail (happyExpListPerState 3) action_4 (19) = happyShift action_18 -action_4 (28) = happyShift action_19 -action_4 (29) = happyShift action_20 -action_4 (31) = happyShift action_21 -action_4 (32) = happyShift action_22 -action_4 (34) = happyShift action_23 -action_4 (35) = happyShift action_8 -action_4 (36) = happyShift action_24 +action_4 (30) = happyShift action_19 +action_4 (31) = happyShift action_20 +action_4 (33) = happyShift action_21 +action_4 (34) = happyShift action_22 +action_4 (36) = happyShift action_23 +action_4 (37) = happyShift action_24 +action_4 (38) = happyShift action_8 +action_4 (39) = happyShift action_25 action_4 (10) = happyGoto action_12 action_4 (11) = happyGoto action_13 action_4 (13) = happyGoto action_14 action_4 (14) = happyGoto action_15 -action_4 (15) = happyGoto action_25 -action_4 (16) = happyGoto action_26 +action_4 (15) = happyGoto action_26 +action_4 (16) = happyGoto action_27 action_4 _ = happyFail (happyExpListPerState 4) action_5 (19) = happyShift action_18 -action_5 (28) = happyShift action_19 -action_5 (29) = happyShift action_20 -action_5 (31) = happyShift action_21 -action_5 (32) = happyShift action_22 -action_5 (34) = happyShift action_23 -action_5 (35) = happyShift action_8 -action_5 (36) = happyShift action_24 +action_5 (30) = happyShift action_19 +action_5 (31) = happyShift action_20 +action_5 (33) = happyShift action_21 +action_5 (34) = happyShift action_22 +action_5 (36) = happyShift action_23 +action_5 (37) = happyShift action_24 +action_5 (38) = happyShift action_8 +action_5 (39) = happyShift action_25 action_5 (10) = happyGoto action_12 action_5 (11) = happyGoto action_13 action_5 (13) = happyGoto action_14 @@ -228,22 +244,23 @@ action_5 (15) = happyGoto action_16 action_5 (17) = happyGoto action_17 action_5 _ = happyFail (happyExpListPerState 5) -action_6 (25) = happyShift action_10 -action_6 (26) = happyShift action_11 +action_6 (27) = happyShift action_10 +action_6 (28) = happyShift action_11 action_6 (18) = happyGoto action_9 action_6 _ = happyFail (happyExpListPerState 6) -action_7 (35) = happyShift action_8 +action_7 (38) = happyShift action_8 action_7 _ = happyFail (happyExpListPerState 7) action_8 _ = happyReduce_7 -action_9 (37) = happyAccept +action_9 (23) = happyShift action_42 +action_9 (40) = happyAccept action_9 _ = happyFail (happyExpListPerState 9) -action_10 _ = happyReduce_26 +action_10 _ = happyReduce_28 -action_11 _ = happyReduce_25 +action_11 _ = happyReduce_27 action_12 _ = happyReduce_10 @@ -251,215 +268,311 @@ action_13 _ = happyReduce_13 action_14 _ = happyReduce_18 -action_15 (21) = happyShift action_32 -action_15 (22) = happyShift action_33 -action_15 _ = happyReduce_21 +action_15 (21) = happyShift action_33 +action_15 (22) = happyShift action_34 +action_15 _ = happyReduce_23 -action_16 _ = happyReduce_24 +action_16 (27) = happyShift action_10 +action_16 (28) = happyShift action_11 +action_16 (18) = happyGoto action_35 +action_16 _ = happyReduce_26 -action_17 (37) = happyAccept +action_17 (40) = happyAccept action_17 _ = happyFail (happyExpListPerState 17) action_18 (19) = happyShift action_18 -action_18 (28) = happyShift action_19 -action_18 (29) = happyShift action_20 -action_18 (31) = happyShift action_21 -action_18 (32) = happyShift action_22 -action_18 (34) = happyShift action_23 -action_18 (35) = happyShift action_8 -action_18 (36) = happyShift action_24 +action_18 (30) = happyShift action_19 +action_18 (31) = happyShift action_20 +action_18 (33) = happyShift action_21 +action_18 (34) = happyShift action_22 +action_18 (36) = happyShift action_23 +action_18 (37) = happyShift action_24 +action_18 (38) = happyShift action_8 +action_18 (39) = happyShift action_25 action_18 (10) = happyGoto action_12 action_18 (11) = happyGoto action_13 action_18 (13) = happyGoto action_14 action_18 (14) = happyGoto action_15 -action_18 (15) = happyGoto action_25 -action_18 (16) = happyGoto action_38 +action_18 (15) = happyGoto action_26 +action_18 (16) = happyGoto action_41 action_18 _ = happyFail (happyExpListPerState 18) action_19 _ = happyReduce_12 action_20 (19) = happyShift action_18 -action_20 (28) = happyShift action_19 -action_20 (29) = happyShift action_20 -action_20 (31) = happyShift action_21 -action_20 (32) = happyShift action_22 -action_20 (34) = happyShift action_23 -action_20 (35) = happyShift action_8 -action_20 (36) = happyShift action_24 +action_20 (30) = happyShift action_19 +action_20 (31) = happyShift action_20 +action_20 (33) = happyShift action_21 +action_20 (34) = happyShift action_22 +action_20 (36) = happyShift action_23 +action_20 (37) = happyShift action_24 +action_20 (38) = happyShift action_8 +action_20 (39) = happyShift action_25 action_20 (10) = happyGoto action_12 action_20 (11) = happyGoto action_13 action_20 (13) = happyGoto action_14 action_20 (14) = happyGoto action_15 -action_20 (15) = happyGoto action_37 +action_20 (15) = happyGoto action_40 action_20 _ = happyFail (happyExpListPerState 20) -action_21 (19) = happyShift action_36 +action_21 (19) = happyShift action_39 action_21 _ = happyFail (happyExpListPerState 21) -action_22 (35) = happyShift action_8 -action_22 (10) = happyGoto action_30 -action_22 (12) = happyGoto action_35 +action_22 (38) = happyShift action_8 +action_22 (10) = happyGoto action_31 +action_22 (12) = happyGoto action_38 action_22 _ = happyFail (happyExpListPerState 22) action_23 _ = happyReduce_11 -action_24 _ = happyReduce_8 +action_24 (38) = happyShift action_8 +action_24 (10) = happyGoto action_37 +action_24 _ = happyFail (happyExpListPerState 24) -action_25 (23) = happyShift action_34 -action_25 _ = happyReduce_23 +action_25 _ = happyReduce_8 -action_26 (37) = happyAccept -action_26 _ = happyFail (happyExpListPerState 26) +action_26 (25) = happyShift action_36 +action_26 (27) = happyShift action_10 +action_26 (28) = happyShift action_11 +action_26 (18) = happyGoto action_35 +action_26 _ = happyReduce_25 -action_27 (37) = happyAccept +action_27 (40) = happyAccept action_27 _ = happyFail (happyExpListPerState 27) -action_28 (21) = happyShift action_32 -action_28 (22) = happyShift action_33 -action_28 (37) = happyAccept +action_28 (27) = happyShift action_10 +action_28 (28) = happyShift action_11 +action_28 (40) = happyAccept +action_28 (18) = happyGoto action_35 action_28 _ = happyFail (happyExpListPerState 28) -action_29 (37) = happyAccept +action_29 (21) = happyShift action_33 +action_29 (22) = happyShift action_34 +action_29 (40) = happyAccept action_29 _ = happyFail (happyExpListPerState 29) -action_30 _ = happyReduce_9 +action_30 (40) = happyAccept +action_30 _ = happyFail (happyExpListPerState 30) -action_31 (37) = happyAccept -action_31 _ = happyFail (happyExpListPerState 31) +action_31 _ = happyReduce_9 -action_32 (19) = happyShift action_18 -action_32 (28) = happyShift action_19 -action_32 (34) = happyShift action_23 -action_32 (35) = happyShift action_8 -action_32 (36) = happyShift action_24 -action_32 (10) = happyGoto action_12 -action_32 (11) = happyGoto action_13 -action_32 (13) = happyGoto action_45 +action_32 (40) = happyAccept action_32 _ = happyFail (happyExpListPerState 32) action_33 (19) = happyShift action_18 -action_33 (28) = happyShift action_19 -action_33 (34) = happyShift action_23 -action_33 (35) = happyShift action_8 -action_33 (36) = happyShift action_24 +action_33 (30) = happyShift action_19 +action_33 (36) = happyShift action_23 +action_33 (38) = happyShift action_8 +action_33 (39) = happyShift action_25 action_33 (10) = happyGoto action_12 action_33 (11) = happyGoto action_13 -action_33 (13) = happyGoto action_44 +action_33 (13) = happyGoto action_52 action_33 _ = happyFail (happyExpListPerState 33) -action_34 (25) = happyShift action_10 -action_34 (26) = happyShift action_11 -action_34 (18) = happyGoto action_43 +action_34 (19) = happyShift action_18 +action_34 (30) = happyShift action_19 +action_34 (36) = happyShift action_23 +action_34 (38) = happyShift action_8 +action_34 (39) = happyShift action_25 +action_34 (10) = happyGoto action_12 +action_34 (11) = happyGoto action_13 +action_34 (13) = happyGoto action_51 action_34 _ = happyFail (happyExpListPerState 34) -action_35 (24) = happyShift action_42 +action_35 (19) = happyShift action_18 +action_35 (23) = happyShift action_42 +action_35 (30) = happyShift action_19 +action_35 (31) = happyShift action_20 +action_35 (33) = happyShift action_21 +action_35 (34) = happyShift action_22 +action_35 (36) = happyShift action_23 +action_35 (37) = happyShift action_24 +action_35 (38) = happyShift action_8 +action_35 (39) = happyShift action_25 +action_35 (10) = happyGoto action_12 +action_35 (11) = happyGoto action_13 +action_35 (13) = happyGoto action_14 +action_35 (14) = happyGoto action_15 +action_35 (15) = happyGoto action_50 action_35 _ = happyFail (happyExpListPerState 35) -action_36 (19) = happyShift action_18 -action_36 (28) = happyShift action_19 -action_36 (29) = happyShift action_20 -action_36 (31) = happyShift action_21 -action_36 (32) = happyShift action_22 -action_36 (34) = happyShift action_23 -action_36 (35) = happyShift action_8 -action_36 (36) = happyShift action_24 -action_36 (10) = happyGoto action_12 -action_36 (11) = happyGoto action_13 -action_36 (13) = happyGoto action_14 -action_36 (14) = happyGoto action_15 -action_36 (15) = happyGoto action_25 -action_36 (16) = happyGoto action_41 +action_36 (27) = happyShift action_10 +action_36 (28) = happyShift action_11 +action_36 (18) = happyGoto action_49 action_36 _ = happyFail (happyExpListPerState 36) -action_37 (33) = happyShift action_40 +action_37 (25) = happyShift action_48 action_37 _ = happyFail (happyExpListPerState 37) -action_38 (20) = happyShift action_39 +action_38 (26) = happyShift action_47 action_38 _ = happyFail (happyExpListPerState 38) -action_39 _ = happyReduce_14 - -action_40 (19) = happyShift action_18 -action_40 (28) = happyShift action_19 -action_40 (29) = happyShift action_20 -action_40 (31) = happyShift action_21 -action_40 (32) = happyShift action_22 -action_40 (34) = happyShift action_23 -action_40 (35) = happyShift action_8 -action_40 (36) = happyShift action_24 -action_40 (10) = happyGoto action_12 -action_40 (11) = happyGoto action_13 -action_40 (13) = happyGoto action_14 -action_40 (14) = happyGoto action_15 -action_40 (15) = happyGoto action_48 +action_39 (19) = happyShift action_18 +action_39 (30) = happyShift action_19 +action_39 (31) = happyShift action_20 +action_39 (33) = happyShift action_21 +action_39 (34) = happyShift action_22 +action_39 (36) = happyShift action_23 +action_39 (37) = happyShift action_24 +action_39 (38) = happyShift action_8 +action_39 (39) = happyShift action_25 +action_39 (10) = happyGoto action_12 +action_39 (11) = happyGoto action_13 +action_39 (13) = happyGoto action_14 +action_39 (14) = happyGoto action_15 +action_39 (15) = happyGoto action_26 +action_39 (16) = happyGoto action_46 +action_39 _ = happyFail (happyExpListPerState 39) + +action_40 (27) = happyShift action_10 +action_40 (28) = happyShift action_11 +action_40 (35) = happyShift action_45 +action_40 (18) = happyGoto action_35 action_40 _ = happyFail (happyExpListPerState 40) -action_41 (20) = happyShift action_47 +action_41 (20) = happyShift action_44 action_41 _ = happyFail (happyExpListPerState 41) -action_42 (19) = happyShift action_18 -action_42 (28) = happyShift action_19 -action_42 (29) = happyShift action_20 -action_42 (31) = happyShift action_21 -action_42 (32) = happyShift action_22 -action_42 (34) = happyShift action_23 -action_42 (35) = happyShift action_8 -action_42 (36) = happyShift action_24 -action_42 (10) = happyGoto action_12 -action_42 (11) = happyGoto action_13 -action_42 (13) = happyGoto action_14 -action_42 (14) = happyGoto action_15 -action_42 (15) = happyGoto action_46 +action_42 (27) = happyShift action_10 +action_42 (28) = happyShift action_11 +action_42 (18) = happyGoto action_43 action_42 _ = happyFail (happyExpListPerState 42) -action_43 _ = happyReduce_22 - -action_44 _ = happyReduce_16 - -action_45 _ = happyReduce_15 - -action_46 (30) = happyShift action_50 +action_43 (23) = happyShift action_42 +action_43 _ = happyReduce_29 + +action_44 _ = happyReduce_14 + +action_45 (19) = happyShift action_18 +action_45 (30) = happyShift action_19 +action_45 (31) = happyShift action_20 +action_45 (33) = happyShift action_21 +action_45 (34) = happyShift action_22 +action_45 (36) = happyShift action_23 +action_45 (37) = happyShift action_24 +action_45 (38) = happyShift action_8 +action_45 (39) = happyShift action_25 +action_45 (10) = happyGoto action_12 +action_45 (11) = happyGoto action_13 +action_45 (13) = happyGoto action_14 +action_45 (14) = happyGoto action_15 +action_45 (15) = happyGoto action_56 +action_45 _ = happyFail (happyExpListPerState 45) + +action_46 (20) = happyShift action_55 action_46 _ = happyFail (happyExpListPerState 46) -action_47 _ = happyReduce_17 - -action_48 (27) = happyShift action_49 +action_47 (19) = happyShift action_18 +action_47 (30) = happyShift action_19 +action_47 (31) = happyShift action_20 +action_47 (33) = happyShift action_21 +action_47 (34) = happyShift action_22 +action_47 (36) = happyShift action_23 +action_47 (37) = happyShift action_24 +action_47 (38) = happyShift action_8 +action_47 (39) = happyShift action_25 +action_47 (10) = happyGoto action_12 +action_47 (11) = happyGoto action_13 +action_47 (13) = happyGoto action_14 +action_47 (14) = happyGoto action_15 +action_47 (15) = happyGoto action_54 +action_47 _ = happyFail (happyExpListPerState 47) + +action_48 (27) = happyShift action_10 +action_48 (28) = happyShift action_11 +action_48 (18) = happyGoto action_53 action_48 _ = happyFail (happyExpListPerState 48) -action_49 (19) = happyShift action_18 -action_49 (28) = happyShift action_19 -action_49 (29) = happyShift action_20 -action_49 (31) = happyShift action_21 -action_49 (32) = happyShift action_22 -action_49 (34) = happyShift action_23 -action_49 (35) = happyShift action_8 -action_49 (36) = happyShift action_24 -action_49 (10) = happyGoto action_12 -action_49 (11) = happyGoto action_13 -action_49 (13) = happyGoto action_14 -action_49 (14) = happyGoto action_15 -action_49 (15) = happyGoto action_52 -action_49 _ = happyFail (happyExpListPerState 49) - -action_50 (19) = happyShift action_18 -action_50 (28) = happyShift action_19 -action_50 (29) = happyShift action_20 -action_50 (31) = happyShift action_21 -action_50 (32) = happyShift action_22 -action_50 (34) = happyShift action_23 -action_50 (35) = happyShift action_8 -action_50 (36) = happyShift action_24 -action_50 (10) = happyGoto action_12 -action_50 (11) = happyGoto action_13 -action_50 (13) = happyGoto action_14 -action_50 (14) = happyGoto action_15 -action_50 (15) = happyGoto action_16 -action_50 (17) = happyGoto action_51 -action_50 _ = happyFail (happyExpListPerState 50) - -action_51 _ = happyReduce_20 - -action_52 _ = happyReduce_19 +action_49 (23) = happyShift action_42 +action_49 _ = happyReduce_24 + +action_50 (27) = happyShift action_10 +action_50 (28) = happyShift action_11 +action_50 (18) = happyGoto action_35 +action_50 _ = happyReduce_22 + +action_51 _ = happyReduce_16 + +action_52 _ = happyReduce_15 + +action_53 (23) = happyShift action_42 +action_53 (24) = happyShift action_59 +action_53 _ = happyFail (happyExpListPerState 53) + +action_54 (27) = happyShift action_10 +action_54 (28) = happyShift action_11 +action_54 (32) = happyShift action_58 +action_54 (18) = happyGoto action_35 +action_54 _ = happyFail (happyExpListPerState 54) + +action_55 _ = happyReduce_17 + +action_56 (27) = happyShift action_10 +action_56 (28) = happyShift action_11 +action_56 (29) = happyShift action_57 +action_56 (18) = happyGoto action_35 +action_56 _ = happyFail (happyExpListPerState 56) + +action_57 (19) = happyShift action_18 +action_57 (30) = happyShift action_19 +action_57 (31) = happyShift action_20 +action_57 (33) = happyShift action_21 +action_57 (34) = happyShift action_22 +action_57 (36) = happyShift action_23 +action_57 (37) = happyShift action_24 +action_57 (38) = happyShift action_8 +action_57 (39) = happyShift action_25 +action_57 (10) = happyGoto action_12 +action_57 (11) = happyGoto action_13 +action_57 (13) = happyGoto action_14 +action_57 (14) = happyGoto action_15 +action_57 (15) = happyGoto action_62 +action_57 _ = happyFail (happyExpListPerState 57) + +action_58 (19) = happyShift action_18 +action_58 (30) = happyShift action_19 +action_58 (31) = happyShift action_20 +action_58 (33) = happyShift action_21 +action_58 (34) = happyShift action_22 +action_58 (36) = happyShift action_23 +action_58 (37) = happyShift action_24 +action_58 (38) = happyShift action_8 +action_58 (39) = happyShift action_25 +action_58 (10) = happyGoto action_12 +action_58 (11) = happyGoto action_13 +action_58 (13) = happyGoto action_14 +action_58 (14) = happyGoto action_15 +action_58 (15) = happyGoto action_16 +action_58 (17) = happyGoto action_61 +action_58 _ = happyFail (happyExpListPerState 58) + +action_59 (19) = happyShift action_18 +action_59 (30) = happyShift action_19 +action_59 (31) = happyShift action_20 +action_59 (33) = happyShift action_21 +action_59 (34) = happyShift action_22 +action_59 (36) = happyShift action_23 +action_59 (37) = happyShift action_24 +action_59 (38) = happyShift action_8 +action_59 (39) = happyShift action_25 +action_59 (10) = happyGoto action_12 +action_59 (11) = happyGoto action_13 +action_59 (13) = happyGoto action_14 +action_59 (14) = happyGoto action_15 +action_59 (15) = happyGoto action_60 +action_59 _ = happyFail (happyExpListPerState 59) + +action_60 (27) = happyShift action_10 +action_60 (28) = happyShift action_11 +action_60 (18) = happyGoto action_35 +action_60 _ = happyReduce_21 + +action_61 _ = happyReduce_20 + +action_62 (27) = happyShift action_10 +action_62 (28) = happyShift action_11 +action_62 (18) = happyGoto action_35 +action_62 _ = happyReduce_19 happyReduce_7 = happySpecReduce_1 10 happyReduction_7 happyReduction_7 (HappyTerminal (PT _ (TV happy_var_1))) @@ -576,50 +689,80 @@ happyReduction_20 ((HappyAbsSyn17 happy_var_6) `HappyStk` (HM.Parser.Abs.ELet happy_var_2 happy_var_4 happy_var_6 ) `HappyStk` happyRest -happyReduce_21 = happySpecReduce_1 15 happyReduction_21 -happyReduction_21 (HappyAbsSyn13 happy_var_1) +happyReduce_21 = happyReduce 6 15 happyReduction_21 +happyReduction_21 ((HappyAbsSyn13 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn18 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn10 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (HM.Parser.Abs.EAbs happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest + +happyReduce_22 = happySpecReduce_3 15 happyReduction_22 +happyReduction_22 (HappyAbsSyn13 happy_var_3) + (HappyAbsSyn18 happy_var_2) + (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (HM.Parser.Abs.EApp happy_var_1 happy_var_2 happy_var_3 + ) +happyReduction_22 _ _ _ = notHappyAtAll + +happyReduce_23 = happySpecReduce_1 15 happyReduction_23 +happyReduction_23 (HappyAbsSyn13 happy_var_1) = HappyAbsSyn13 (happy_var_1 ) -happyReduction_21 _ = notHappyAtAll +happyReduction_23 _ = notHappyAtAll -happyReduce_22 = happySpecReduce_3 16 happyReduction_22 -happyReduction_22 (HappyAbsSyn18 happy_var_3) +happyReduce_24 = happySpecReduce_3 16 happyReduction_24 +happyReduction_24 (HappyAbsSyn18 happy_var_3) _ (HappyAbsSyn13 happy_var_1) = HappyAbsSyn13 (HM.Parser.Abs.ETyped happy_var_1 happy_var_3 ) -happyReduction_22 _ _ _ = notHappyAtAll +happyReduction_24 _ _ _ = notHappyAtAll -happyReduce_23 = happySpecReduce_1 16 happyReduction_23 -happyReduction_23 (HappyAbsSyn13 happy_var_1) +happyReduce_25 = happySpecReduce_1 16 happyReduction_25 +happyReduction_25 (HappyAbsSyn13 happy_var_1) = HappyAbsSyn13 (happy_var_1 ) -happyReduction_23 _ = notHappyAtAll +happyReduction_25 _ = notHappyAtAll -happyReduce_24 = happySpecReduce_1 17 happyReduction_24 -happyReduction_24 (HappyAbsSyn13 happy_var_1) +happyReduce_26 = happySpecReduce_1 17 happyReduction_26 +happyReduction_26 (HappyAbsSyn13 happy_var_1) = HappyAbsSyn17 (HM.Parser.Abs.ScopedExp happy_var_1 ) -happyReduction_24 _ = notHappyAtAll +happyReduction_26 _ = notHappyAtAll -happyReduce_25 = happySpecReduce_1 18 happyReduction_25 -happyReduction_25 _ +happyReduce_27 = happySpecReduce_1 18 happyReduction_27 +happyReduction_27 _ = HappyAbsSyn18 (HM.Parser.Abs.TNat ) -happyReduce_26 = happySpecReduce_1 18 happyReduction_26 -happyReduction_26 _ +happyReduce_28 = happySpecReduce_1 18 happyReduction_28 +happyReduction_28 _ = HappyAbsSyn18 (HM.Parser.Abs.TBool ) +happyReduce_29 = happySpecReduce_3 18 happyReduction_29 +happyReduction_29 (HappyAbsSyn18 happy_var_3) + _ + (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (HM.Parser.Abs.TArrow happy_var_1 happy_var_3 + ) +happyReduction_29 _ _ _ = notHappyAtAll + happyNewToken action sts stk [] = - action 37 37 notHappyAtAll (HappyState action) sts stk [] + action 40 40 notHappyAtAll (HappyState action) sts stk [] happyNewToken action sts stk (tk:tks) = let cont i = action i i tk (HappyState action) sts stk tks in @@ -640,12 +783,15 @@ happyNewToken action sts stk (tk:tks) = PT _ (TS _ 14) -> cont 32; PT _ (TS _ 15) -> cont 33; PT _ (TS _ 16) -> cont 34; - PT _ (TV happy_dollar_dollar) -> cont 35; - PT _ (TI happy_dollar_dollar) -> cont 36; + PT _ (TS _ 17) -> cont 35; + PT _ (TS _ 18) -> cont 36; + PT _ (TS _ 19) -> cont 37; + PT _ (TV happy_dollar_dollar) -> cont 38; + PT _ (TI happy_dollar_dollar) -> cont 39; _ -> happyError' ((tk:tks), []) } -happyError_ explist 37 tk tks = happyError' (tks, explist) +happyError_ explist 40 tk tks = happyError' (tks, explist) happyError_ explist _ tk tks = happyError' ((tk:tks), explist) happyThen :: () => Err a -> (a -> Err b) -> Err b diff --git a/src/HM/Parser/Par.y b/src/HM/Parser/Par.y index aa45000..7a5fa21 100644 --- a/src/HM/Parser/Par.y +++ b/src/HM/Parser/Par.y @@ -39,18 +39,21 @@ import HM.Parser.Lex ')' { PT _ (TS _ 2) } '+' { PT _ (TS _ 3) } '-' { PT _ (TS _ 4) } - ':' { PT _ (TS _ 5) } - '=' { PT _ (TS _ 6) } - 'Bool' { PT _ (TS _ 7) } - 'Nat' { PT _ (TS _ 8) } - 'else' { PT _ (TS _ 9) } - 'false' { PT _ (TS _ 10) } - 'if' { PT _ (TS _ 11) } - 'in' { PT _ (TS _ 12) } - 'iszero' { PT _ (TS _ 13) } - 'let' { PT _ (TS _ 14) } - 'then' { PT _ (TS _ 15) } - 'true' { PT _ (TS _ 16) } + '->' { PT _ (TS _ 5) } + '.' { PT _ (TS _ 6) } + ':' { PT _ (TS _ 7) } + '=' { PT _ (TS _ 8) } + 'Bool' { PT _ (TS _ 9) } + 'Nat' { PT _ (TS _ 10) } + 'else' { PT _ (TS _ 11) } + 'false' { PT _ (TS _ 12) } + 'if' { PT _ (TS _ 13) } + 'in' { PT _ (TS _ 14) } + 'iszero' { PT _ (TS _ 15) } + 'let' { PT _ (TS _ 16) } + 'then' { PT _ (TS _ 17) } + 'true' { PT _ (TS _ 18) } + 'λ' { PT _ (TS _ 19) } L_Ident { PT _ (TV $$) } L_integ { PT _ (TI $$) } @@ -84,6 +87,8 @@ Exp1 :: { HM.Parser.Abs.Exp } Exp1 : 'if' Exp1 'then' Exp1 'else' Exp1 { HM.Parser.Abs.EIf $2 $4 $6 } | 'let' Pattern '=' Exp1 'in' ScopedExp { HM.Parser.Abs.ELet $2 $4 $6 } + | 'λ' Ident ':' Type '.' Exp1 { HM.Parser.Abs.EAbs $2 $4 $6 } + | Exp1 Type Exp1 { HM.Parser.Abs.EApp $1 $2 $3 } | Exp2 { $1 } Exp :: { HM.Parser.Abs.Exp } @@ -94,7 +99,9 @@ ScopedExp : Exp1 { HM.Parser.Abs.ScopedExp $1 } Type :: { HM.Parser.Abs.Type } Type - : 'Nat' { HM.Parser.Abs.TNat } | 'Bool' { HM.Parser.Abs.TBool } + : 'Nat' { HM.Parser.Abs.TNat } + | 'Bool' { HM.Parser.Abs.TBool } + | Type '->' Type { HM.Parser.Abs.TArrow $1 $3 } { diff --git a/src/HM/Parser/Print.hs b/src/HM/Parser/Print.hs index 1d75666..2eb5f5e 100644 --- a/src/HM/Parser/Print.hs +++ b/src/HM/Parser/Print.hs @@ -155,6 +155,8 @@ instance Print HM.Parser.Abs.Exp where HM.Parser.Abs.EIsZero exp -> prPrec i 2 (concatD [doc (showString "iszero"), doc (showString "("), prt 0 exp, doc (showString ")")]) HM.Parser.Abs.ETyped exp type_ -> prPrec i 0 (concatD [prt 1 exp, doc (showString ":"), prt 0 type_]) HM.Parser.Abs.ELet pattern_ exp scopedexp -> prPrec i 1 (concatD [doc (showString "let"), prt 0 pattern_, doc (showString "="), prt 1 exp, doc (showString "in"), prt 0 scopedexp]) + HM.Parser.Abs.EAbs id_ type_ exp -> prPrec i 1 (concatD [doc (showString "\955"), prt 0 id_, doc (showString ":"), prt 0 type_, doc (showString "."), prt 1 exp]) + HM.Parser.Abs.EApp exp1 type_ exp2 -> prPrec i 1 (concatD [prt 1 exp1, prt 0 type_, prt 1 exp2]) instance Print HM.Parser.Abs.ScopedExp where prt i = \case @@ -164,3 +166,4 @@ instance Print HM.Parser.Abs.Type where prt i = \case HM.Parser.Abs.TNat -> prPrec i 0 (concatD [doc (showString "Nat")]) HM.Parser.Abs.TBool -> prPrec i 0 (concatD [doc (showString "Bool")]) + HM.Parser.Abs.TArrow type_1 type_2 -> prPrec i 0 (concatD [prt 0 type_1, doc (showString "->"), prt 0 type_2]) diff --git a/src/HM/Parser/Skel.hs b/src/HM/Parser/Skel.hs index cede61a..f6fb98d 100644 --- a/src/HM/Parser/Skel.hs +++ b/src/HM/Parser/Skel.hs @@ -35,6 +35,8 @@ transExp x = case x of HM.Parser.Abs.EIsZero exp -> failure x HM.Parser.Abs.ETyped exp type_ -> failure x HM.Parser.Abs.ELet pattern_ exp scopedexp -> failure x + HM.Parser.Abs.EAbs ident type_ exp -> failure x + HM.Parser.Abs.EApp exp1 type_ exp2 -> failure x transScopedExp :: HM.Parser.Abs.ScopedExp -> Result transScopedExp x = case x of @@ -44,3 +46,4 @@ transType :: HM.Parser.Abs.Type -> Result transType x = case x of HM.Parser.Abs.TNat -> failure x HM.Parser.Abs.TBool -> failure x + HM.Parser.Abs.TArrow type_1 type_2 -> failure x diff --git a/src/HM/Typecheck.hs b/src/HM/Typecheck.hs index b9fd830..414c8e3 100644 --- a/src/HM/Typecheck.hs +++ b/src/HM/Typecheck.hs @@ -2,13 +2,17 @@ module HM.Typecheck where -import Control.Monad.Foil (NameMap, addNameBinder, emptyNameMap, - lookupName) -import qualified Control.Monad.Foil as Foil +import Control.Monad.Foil + ( NameMap, + addNameBinder, + emptyNameMap, + lookupName, + ) +import qualified Control.Monad.Foil as Foil import qualified Control.Monad.Free.Foil as FreeFoil -import HM.Parser.Abs (Type (..)) -import qualified HM.Parser.Print as Raw -import HM.Syntax +import HM.Parser.Abs (Type (..)) +import qualified HM.Parser.Print as Raw +import HM.Syntax -- $setup -- >>> :set -XOverloadedStrings @@ -62,10 +66,13 @@ inferType scope (ESub l r) = do inferType scope (EIsZero e) = do _ <- typecheck scope e TNat return TBool -inferType scope (ELet e1 x e2) = do -- Γ ⊢ let x = e1 in e2 : ? - type1 <- inferType scope e1 -- Γ ⊢ e1 : type1 - let newScope = addNameBinder x type1 scope -- Γ' = Γ, x : type1 - inferType newScope e2 -- Γ' ⊢ e2 : ? +inferType scope (ELet e1 x e2) = do + -- Γ ⊢ let x = e1 in e2 : ? + type1 <- inferType scope e1 -- Γ ⊢ e1 : type1 + let newScope = addNameBinder x type1 scope -- Γ' = Γ, x : type1 + inferType newScope e2 -- Γ' ⊢ e2 : ? inferType scope (ETyped expr type_) = do typecheck scope expr type_ -inferType scope (FreeFoil.Var n) = Right (lookupName n scope) -- Γ, x : T ⊢ x : T +inferType scope (FreeFoil.Var n) = Right (lookupName n scope) -- Γ, x : T ⊢ x : T +inferType scope (EApp e1 _ e2) = undefined +inferType scope (EAbs x type_ e) = undefined \ No newline at end of file From 1055c2c177fb67297b9d47b444e63aacba2bae8d Mon Sep 17 00:00:00 2001 From: frog-da <84839431+frog-da@users.noreply.github.com> Date: Thu, 29 Aug 2024 00:19:48 +0300 Subject: [PATCH 2/8] Typecheck is done --- grammar/hindley-milner.cf | 4 +- src/HM/Eval.hs | 36 +++--- src/HM/Parser/Abs.hs | 4 +- src/HM/Parser/Doc.txt | 4 +- src/HM/Parser/Par.hs | 236 ++++++++++++++++++++++++-------------- src/HM/Parser/Par.y | 4 +- src/HM/Parser/Print.hs | 4 +- src/HM/Parser/Skel.hs | 4 +- src/HM/Syntax.hs | 52 +++++---- src/HM/Typecheck.hs | 31 +++-- 10 files changed, 234 insertions(+), 145 deletions(-) diff --git a/grammar/hindley-milner.cf b/grammar/hindley-milner.cf index 06acff4..d14b653 100644 --- a/grammar/hindley-milner.cf +++ b/grammar/hindley-milner.cf @@ -10,8 +10,8 @@ EIf. Exp1 ::= "if" Exp1 "then" Exp1 "else" Exp1 ; EIsZero. Exp2 ::= "iszero" "(" Exp ")" ; ETyped. Exp ::= Exp1 ":" Type ; ELet. Exp1 ::= "let" Pattern "=" Exp1 "in" ScopedExp ; -EAbs. Exp1 ::= "λ" Ident ":" Type "." Exp1 ; -EApp. Exp1 ::= Exp1 Type Exp1 ; +EAbs. Exp1 ::= "λ" Pattern ":" Type "." ScopedExp ; +EApp. Exp1 ::= Exp1 Exp1 ; ScopedExp. ScopedExp ::= Exp1 ; diff --git a/src/HM/Eval.hs b/src/HM/Eval.hs index 3923e3f..ca50494 100644 --- a/src/HM/Eval.hs +++ b/src/HM/Eval.hs @@ -1,10 +1,15 @@ {-# LANGUAGE LambdaCase #-} + module HM.Eval where -import Control.Monad.Foil (Distinct, Scope, addSubst, - identitySubst) -import Control.Monad.Free.Foil (AST (Var), substitute) -import HM.Syntax +import Control.Monad.Foil + ( Distinct, + Scope, + addSubst, + identitySubst, + ) +import Control.Monad.Free.Foil (AST (Var), substitute) +import HM.Syntax -- $setup -- >>> :set -XOverloadedStrings @@ -14,7 +19,7 @@ import HM.Syntax -- Right "true" -- >>> eval emptyScope "if (iszero (2 - (true + 1))) then true else 0" -- Left "Unsupported expression in addition" -eval :: Distinct n => Scope n -> Exp n -> Either String (Exp n) +eval :: (Distinct n) => Scope n -> Exp n -> Either String (Exp n) eval _scope (Var x) = Right (Var x) eval _scope ETrue = Right ETrue eval _scope EFalse = Right EFalse @@ -24,26 +29,27 @@ eval scope (EAdd l r) = do r' <- eval scope r case (l', r') of (ENat x, ENat y) -> Right (ENat (x + y)) - _ -> Left "Unsupported expression in addition" + _ -> Left "Unsupported expression in addition" eval scope (ESub l r) = do l' <- eval scope l r' <- eval scope r case (l', r') of (ENat x, ENat y) -> Right (ENat (x - y)) - _ -> Left "Unsupported expression in subtraction" + _ -> Left "Unsupported expression in subtraction" eval scope (EIf cond then_ else_) = do cond' <- eval scope cond case cond' of - ETrue -> eval scope then_ + ETrue -> eval scope then_ EFalse -> eval scope else_ - _ -> Left "Unsupported condition in if statement" -eval scope (EIsZero n) = eval scope n >>= \case - ENat n' - | n' == 0 -> Right ETrue - | otherwise -> Right EFalse - _ -> Left "Unsupported expression in iszero" + _ -> Left "Unsupported condition in if statement" +eval scope (EIsZero n) = + eval scope n >>= \case + ENat n' + | n' == 0 -> Right ETrue + | otherwise -> Right EFalse + _ -> Left "Unsupported expression in iszero" eval scope (ETyped e _) = eval scope e eval scope (ELet e1 x e2) = do e1' <- eval scope e1 let subst = addSubst identitySubst x e1' - eval scope (substitute scope subst e2) + eval scope (substitute scope subst e2) \ No newline at end of file diff --git a/src/HM/Parser/Abs.hs b/src/HM/Parser/Abs.hs index 7b75166..dcff1da 100644 --- a/src/HM/Parser/Abs.hs +++ b/src/HM/Parser/Abs.hs @@ -29,8 +29,8 @@ data Exp | EIsZero Exp | ETyped Exp Type | ELet Pattern Exp ScopedExp - | EAbs Ident Type Exp - | EApp Exp Type Exp + | EAbs Pattern Type ScopedExp + | EApp Exp Exp deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data ScopedExp = ScopedExp Exp diff --git a/src/HM/Parser/Doc.txt b/src/HM/Parser/Doc.txt index 85f2805..9903e6a 100644 --- a/src/HM/Parser/Doc.txt +++ b/src/HM/Parser/Doc.txt @@ -54,8 +54,8 @@ All other symbols are terminals. | | **|** | //Exp3// | //Exp1// | -> | ``if`` //Exp1// ``then`` //Exp1// ``else`` //Exp1// | | **|** | ``let`` //Pattern// ``=`` //Exp1// ``in`` //ScopedExp// - | | **|** | ``λ`` //Ident// ``:`` //Type// ``.`` //Exp1// - | | **|** | //Exp1// //Type// //Exp1// + | | **|** | ``λ`` //Pattern// ``:`` //Type// ``.`` //ScopedExp// + | | **|** | //Exp1// //Exp1// | | **|** | //Exp2// | //Exp// | -> | //Exp1// ``:`` //Type// | | **|** | //Exp1// diff --git a/src/HM/Parser/Par.hs b/src/HM/Parser/Par.hs index 7145e31..dd374ec 100644 --- a/src/HM/Parser/Par.hs +++ b/src/HM/Parser/Par.hs @@ -111,8 +111,7 @@ action_0, action_58, action_59, action_60, - action_61, - action_62 :: () => Prelude.Int -> ({-HappyReduction (Err) = -} + action_61 :: () => Prelude.Int -> ({-HappyReduction (Err) = -} Prelude.Int -> (Token) -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) @@ -151,7 +150,7 @@ happyReduce_7, -> [(Token)] -> (Err) HappyAbsSyn) happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int -happyExpList = Happy_Data_Array.listArray (0,184) ([0,0,32,1024,26656,0,8196,105,1024,31584,0,24580,123,1024,31584,0,3072,0,0,8192,0,0,0,16384,0,0,0,0,0,0,0,0,0,0,0,0,0,0,12288,0,0,0,0,0,0,0,24580,123,0,0,0,24580,123,1024,0,0,0,32,0,0,0,0,32,0,0,0,3328,0,0,0,0,3072,0,12288,0,0,0,0,0,0,0,0,0,1024,26656,0,8196,104,17408,31584,0,3072,0,0,1,0,512,0,1024,31584,0,3072,4,2048,0,0,3072,0,0,0,0,0,0,1024,31584,0,8,0,1024,31584,0,3072,0,16384,0,0,0,0,0,0,0,0,0,49152,0,0,35840,0,0,0,0,7168,0,1024,31584,0,24580,123,1024,31584,0,0,0,0,0,0,0,0,0 +happyExpList = Happy_Data_Array.listArray (0,232) ([0,0,32,1024,26656,0,8196,105,1024,31584,0,24580,123,1024,31584,0,3072,0,0,8192,0,0,0,16384,0,0,0,0,0,0,0,0,0,0,0,0,0,0,12288,0,0,0,0,0,0,0,24580,123,0,0,0,24580,123,1024,0,0,0,32,0,0,0,0,32,0,0,0,24836,123,0,0,0,24580,123,12288,0,0,0,0,0,0,0,0,0,1024,26656,0,8196,104,0,0,0,3072,0,0,1,0,512,0,1024,31584,0,24580,127,2048,0,0,3072,0,0,0,0,0,0,1024,31584,0,8,0,1024,31584,0,3072,0,16384,0,0,0,0,0,0,0,192,0,1024,31712,0,0,0,1024,31600,0,24580,123,1024,31584,0,24580,123,0,0,0,0,0,0,0,0 ]) {-# NOINLINE happyExpListPerState #-} @@ -272,9 +271,20 @@ action_15 (21) = happyShift action_33 action_15 (22) = happyShift action_34 action_15 _ = happyReduce_23 -action_16 (27) = happyShift action_10 -action_16 (28) = happyShift action_11 -action_16 (18) = happyGoto action_35 +action_16 (19) = happyShift action_18 +action_16 (30) = happyShift action_19 +action_16 (31) = happyShift action_20 +action_16 (33) = happyShift action_21 +action_16 (34) = happyShift action_22 +action_16 (36) = happyShift action_23 +action_16 (37) = happyShift action_24 +action_16 (38) = happyShift action_8 +action_16 (39) = happyShift action_25 +action_16 (10) = happyGoto action_12 +action_16 (11) = happyGoto action_13 +action_16 (13) = happyGoto action_14 +action_16 (14) = happyGoto action_15 +action_16 (15) = happyGoto action_35 action_16 _ = happyReduce_26 action_17 (40) = happyAccept @@ -326,24 +336,47 @@ action_22 _ = happyFail (happyExpListPerState 22) action_23 _ = happyReduce_11 action_24 (38) = happyShift action_8 -action_24 (10) = happyGoto action_37 +action_24 (10) = happyGoto action_31 +action_24 (12) = happyGoto action_37 action_24 _ = happyFail (happyExpListPerState 24) action_25 _ = happyReduce_8 +action_26 (19) = happyShift action_18 action_26 (25) = happyShift action_36 -action_26 (27) = happyShift action_10 -action_26 (28) = happyShift action_11 -action_26 (18) = happyGoto action_35 +action_26 (30) = happyShift action_19 +action_26 (31) = happyShift action_20 +action_26 (33) = happyShift action_21 +action_26 (34) = happyShift action_22 +action_26 (36) = happyShift action_23 +action_26 (37) = happyShift action_24 +action_26 (38) = happyShift action_8 +action_26 (39) = happyShift action_25 +action_26 (10) = happyGoto action_12 +action_26 (11) = happyGoto action_13 +action_26 (13) = happyGoto action_14 +action_26 (14) = happyGoto action_15 +action_26 (15) = happyGoto action_35 action_26 _ = happyReduce_25 action_27 (40) = happyAccept action_27 _ = happyFail (happyExpListPerState 27) -action_28 (27) = happyShift action_10 -action_28 (28) = happyShift action_11 +action_28 (19) = happyShift action_18 +action_28 (30) = happyShift action_19 +action_28 (31) = happyShift action_20 +action_28 (33) = happyShift action_21 +action_28 (34) = happyShift action_22 +action_28 (36) = happyShift action_23 +action_28 (37) = happyShift action_24 +action_28 (38) = happyShift action_8 +action_28 (39) = happyShift action_25 action_28 (40) = happyAccept -action_28 (18) = happyGoto action_35 +action_28 (10) = happyGoto action_12 +action_28 (11) = happyGoto action_13 +action_28 (13) = happyGoto action_14 +action_28 (14) = happyGoto action_15 +action_28 (15) = happyGoto action_35 action_28 _ = happyFail (happyExpListPerState 28) action_29 (21) = happyShift action_33 @@ -366,7 +399,7 @@ action_33 (38) = happyShift action_8 action_33 (39) = happyShift action_25 action_33 (10) = happyGoto action_12 action_33 (11) = happyGoto action_13 -action_33 (13) = happyGoto action_52 +action_33 (13) = happyGoto action_51 action_33 _ = happyFail (happyExpListPerState 33) action_34 (19) = happyShift action_18 @@ -376,11 +409,10 @@ action_34 (38) = happyShift action_8 action_34 (39) = happyShift action_25 action_34 (10) = happyGoto action_12 action_34 (11) = happyGoto action_13 -action_34 (13) = happyGoto action_51 +action_34 (13) = happyGoto action_50 action_34 _ = happyFail (happyExpListPerState 34) action_35 (19) = happyShift action_18 -action_35 (23) = happyShift action_42 action_35 (30) = happyShift action_19 action_35 (31) = happyShift action_20 action_35 (33) = happyShift action_21 @@ -393,8 +425,8 @@ action_35 (10) = happyGoto action_12 action_35 (11) = happyGoto action_13 action_35 (13) = happyGoto action_14 action_35 (14) = happyGoto action_15 -action_35 (15) = happyGoto action_50 -action_35 _ = happyFail (happyExpListPerState 35) +action_35 (15) = happyGoto action_35 +action_35 _ = happyReduce_22 action_36 (27) = happyShift action_10 action_36 (28) = happyShift action_11 @@ -424,10 +456,21 @@ action_39 (15) = happyGoto action_26 action_39 (16) = happyGoto action_46 action_39 _ = happyFail (happyExpListPerState 39) -action_40 (27) = happyShift action_10 -action_40 (28) = happyShift action_11 +action_40 (19) = happyShift action_18 +action_40 (30) = happyShift action_19 +action_40 (31) = happyShift action_20 +action_40 (33) = happyShift action_21 +action_40 (34) = happyShift action_22 action_40 (35) = happyShift action_45 -action_40 (18) = happyGoto action_35 +action_40 (36) = happyShift action_23 +action_40 (37) = happyShift action_24 +action_40 (38) = happyShift action_8 +action_40 (39) = happyShift action_25 +action_40 (10) = happyGoto action_12 +action_40 (11) = happyGoto action_13 +action_40 (13) = happyGoto action_14 +action_40 (14) = happyGoto action_15 +action_40 (15) = happyGoto action_35 action_40 _ = happyFail (happyExpListPerState 40) action_41 (20) = happyShift action_44 @@ -456,10 +499,10 @@ action_45 (10) = happyGoto action_12 action_45 (11) = happyGoto action_13 action_45 (13) = happyGoto action_14 action_45 (14) = happyGoto action_15 -action_45 (15) = happyGoto action_56 +action_45 (15) = happyGoto action_55 action_45 _ = happyFail (happyExpListPerState 45) -action_46 (20) = happyShift action_55 +action_46 (20) = happyShift action_54 action_46 _ = happyFail (happyExpListPerState 46) action_47 (19) = happyShift action_18 @@ -475,42 +518,75 @@ action_47 (10) = happyGoto action_12 action_47 (11) = happyGoto action_13 action_47 (13) = happyGoto action_14 action_47 (14) = happyGoto action_15 -action_47 (15) = happyGoto action_54 +action_47 (15) = happyGoto action_53 action_47 _ = happyFail (happyExpListPerState 47) action_48 (27) = happyShift action_10 action_48 (28) = happyShift action_11 -action_48 (18) = happyGoto action_53 +action_48 (18) = happyGoto action_52 action_48 _ = happyFail (happyExpListPerState 48) action_49 (23) = happyShift action_42 action_49 _ = happyReduce_24 -action_50 (27) = happyShift action_10 -action_50 (28) = happyShift action_11 -action_50 (18) = happyGoto action_35 -action_50 _ = happyReduce_22 - -action_51 _ = happyReduce_16 - -action_52 _ = happyReduce_15 - -action_53 (23) = happyShift action_42 -action_53 (24) = happyShift action_59 +action_50 _ = happyReduce_16 + +action_51 _ = happyReduce_15 + +action_52 (23) = happyShift action_42 +action_52 (24) = happyShift action_58 +action_52 _ = happyFail (happyExpListPerState 52) + +action_53 (19) = happyShift action_18 +action_53 (30) = happyShift action_19 +action_53 (31) = happyShift action_20 +action_53 (32) = happyShift action_57 +action_53 (33) = happyShift action_21 +action_53 (34) = happyShift action_22 +action_53 (36) = happyShift action_23 +action_53 (37) = happyShift action_24 +action_53 (38) = happyShift action_8 +action_53 (39) = happyShift action_25 +action_53 (10) = happyGoto action_12 +action_53 (11) = happyGoto action_13 +action_53 (13) = happyGoto action_14 +action_53 (14) = happyGoto action_15 +action_53 (15) = happyGoto action_35 action_53 _ = happyFail (happyExpListPerState 53) -action_54 (27) = happyShift action_10 -action_54 (28) = happyShift action_11 -action_54 (32) = happyShift action_58 -action_54 (18) = happyGoto action_35 -action_54 _ = happyFail (happyExpListPerState 54) - -action_55 _ = happyReduce_17 - -action_56 (27) = happyShift action_10 -action_56 (28) = happyShift action_11 -action_56 (29) = happyShift action_57 -action_56 (18) = happyGoto action_35 +action_54 _ = happyReduce_17 + +action_55 (19) = happyShift action_18 +action_55 (29) = happyShift action_56 +action_55 (30) = happyShift action_19 +action_55 (31) = happyShift action_20 +action_55 (33) = happyShift action_21 +action_55 (34) = happyShift action_22 +action_55 (36) = happyShift action_23 +action_55 (37) = happyShift action_24 +action_55 (38) = happyShift action_8 +action_55 (39) = happyShift action_25 +action_55 (10) = happyGoto action_12 +action_55 (11) = happyGoto action_13 +action_55 (13) = happyGoto action_14 +action_55 (14) = happyGoto action_15 +action_55 (15) = happyGoto action_35 +action_55 _ = happyFail (happyExpListPerState 55) + +action_56 (19) = happyShift action_18 +action_56 (30) = happyShift action_19 +action_56 (31) = happyShift action_20 +action_56 (33) = happyShift action_21 +action_56 (34) = happyShift action_22 +action_56 (36) = happyShift action_23 +action_56 (37) = happyShift action_24 +action_56 (38) = happyShift action_8 +action_56 (39) = happyShift action_25 +action_56 (10) = happyGoto action_12 +action_56 (11) = happyGoto action_13 +action_56 (13) = happyGoto action_14 +action_56 (14) = happyGoto action_15 +action_56 (15) = happyGoto action_61 action_56 _ = happyFail (happyExpListPerState 56) action_57 (19) = happyShift action_18 @@ -526,7 +602,8 @@ action_57 (10) = happyGoto action_12 action_57 (11) = happyGoto action_13 action_57 (13) = happyGoto action_14 action_57 (14) = happyGoto action_15 -action_57 (15) = happyGoto action_62 +action_57 (15) = happyGoto action_16 +action_57 (17) = happyGoto action_60 action_57 _ = happyFail (happyExpListPerState 57) action_58 (19) = happyShift action_18 @@ -543,36 +620,28 @@ action_58 (11) = happyGoto action_13 action_58 (13) = happyGoto action_14 action_58 (14) = happyGoto action_15 action_58 (15) = happyGoto action_16 -action_58 (17) = happyGoto action_61 +action_58 (17) = happyGoto action_59 action_58 _ = happyFail (happyExpListPerState 58) -action_59 (19) = happyShift action_18 -action_59 (30) = happyShift action_19 -action_59 (31) = happyShift action_20 -action_59 (33) = happyShift action_21 -action_59 (34) = happyShift action_22 -action_59 (36) = happyShift action_23 -action_59 (37) = happyShift action_24 -action_59 (38) = happyShift action_8 -action_59 (39) = happyShift action_25 -action_59 (10) = happyGoto action_12 -action_59 (11) = happyGoto action_13 -action_59 (13) = happyGoto action_14 -action_59 (14) = happyGoto action_15 -action_59 (15) = happyGoto action_60 -action_59 _ = happyFail (happyExpListPerState 59) - -action_60 (27) = happyShift action_10 -action_60 (28) = happyShift action_11 -action_60 (18) = happyGoto action_35 -action_60 _ = happyReduce_21 - -action_61 _ = happyReduce_20 - -action_62 (27) = happyShift action_10 -action_62 (28) = happyShift action_11 -action_62 (18) = happyGoto action_35 -action_62 _ = happyReduce_19 +action_59 _ = happyReduce_21 + +action_60 _ = happyReduce_20 + +action_61 (19) = happyShift action_18 +action_61 (30) = happyShift action_19 +action_61 (31) = happyShift action_20 +action_61 (33) = happyShift action_21 +action_61 (34) = happyShift action_22 +action_61 (36) = happyShift action_23 +action_61 (37) = happyShift action_24 +action_61 (38) = happyShift action_8 +action_61 (39) = happyShift action_25 +action_61 (10) = happyGoto action_12 +action_61 (11) = happyGoto action_13 +action_61 (13) = happyGoto action_14 +action_61 (14) = happyGoto action_15 +action_61 (15) = happyGoto action_35 +action_61 _ = happyReduce_19 happyReduce_7 = happySpecReduce_1 10 happyReduction_7 happyReduction_7 (HappyTerminal (PT _ (TV happy_var_1))) @@ -690,25 +759,24 @@ happyReduction_20 ((HappyAbsSyn17 happy_var_6) `HappyStk` ) `HappyStk` happyRest happyReduce_21 = happyReduce 6 15 happyReduction_21 -happyReduction_21 ((HappyAbsSyn13 happy_var_6) `HappyStk` +happyReduction_21 ((HappyAbsSyn17 happy_var_6) `HappyStk` _ `HappyStk` (HappyAbsSyn18 happy_var_4) `HappyStk` _ `HappyStk` - (HappyAbsSyn10 happy_var_2) `HappyStk` + (HappyAbsSyn12 happy_var_2) `HappyStk` _ `HappyStk` happyRest) = HappyAbsSyn13 (HM.Parser.Abs.EAbs happy_var_2 happy_var_4 happy_var_6 ) `HappyStk` happyRest -happyReduce_22 = happySpecReduce_3 15 happyReduction_22 -happyReduction_22 (HappyAbsSyn13 happy_var_3) - (HappyAbsSyn18 happy_var_2) +happyReduce_22 = happySpecReduce_2 15 happyReduction_22 +happyReduction_22 (HappyAbsSyn13 happy_var_2) (HappyAbsSyn13 happy_var_1) = HappyAbsSyn13 - (HM.Parser.Abs.EApp happy_var_1 happy_var_2 happy_var_3 + (HM.Parser.Abs.EApp happy_var_1 happy_var_2 ) -happyReduction_22 _ _ _ = notHappyAtAll +happyReduction_22 _ _ = notHappyAtAll happyReduce_23 = happySpecReduce_1 15 happyReduction_23 happyReduction_23 (HappyAbsSyn13 happy_var_1) diff --git a/src/HM/Parser/Par.y b/src/HM/Parser/Par.y index 7a5fa21..8746dd9 100644 --- a/src/HM/Parser/Par.y +++ b/src/HM/Parser/Par.y @@ -87,8 +87,8 @@ Exp1 :: { HM.Parser.Abs.Exp } Exp1 : 'if' Exp1 'then' Exp1 'else' Exp1 { HM.Parser.Abs.EIf $2 $4 $6 } | 'let' Pattern '=' Exp1 'in' ScopedExp { HM.Parser.Abs.ELet $2 $4 $6 } - | 'λ' Ident ':' Type '.' Exp1 { HM.Parser.Abs.EAbs $2 $4 $6 } - | Exp1 Type Exp1 { HM.Parser.Abs.EApp $1 $2 $3 } + | 'λ' Pattern ':' Type '.' ScopedExp { HM.Parser.Abs.EAbs $2 $4 $6 } + | Exp1 Exp1 { HM.Parser.Abs.EApp $1 $2 } | Exp2 { $1 } Exp :: { HM.Parser.Abs.Exp } diff --git a/src/HM/Parser/Print.hs b/src/HM/Parser/Print.hs index 2eb5f5e..40236d2 100644 --- a/src/HM/Parser/Print.hs +++ b/src/HM/Parser/Print.hs @@ -155,8 +155,8 @@ instance Print HM.Parser.Abs.Exp where HM.Parser.Abs.EIsZero exp -> prPrec i 2 (concatD [doc (showString "iszero"), doc (showString "("), prt 0 exp, doc (showString ")")]) HM.Parser.Abs.ETyped exp type_ -> prPrec i 0 (concatD [prt 1 exp, doc (showString ":"), prt 0 type_]) HM.Parser.Abs.ELet pattern_ exp scopedexp -> prPrec i 1 (concatD [doc (showString "let"), prt 0 pattern_, doc (showString "="), prt 1 exp, doc (showString "in"), prt 0 scopedexp]) - HM.Parser.Abs.EAbs id_ type_ exp -> prPrec i 1 (concatD [doc (showString "\955"), prt 0 id_, doc (showString ":"), prt 0 type_, doc (showString "."), prt 1 exp]) - HM.Parser.Abs.EApp exp1 type_ exp2 -> prPrec i 1 (concatD [prt 1 exp1, prt 0 type_, prt 1 exp2]) + HM.Parser.Abs.EAbs pattern_ type_ scopedexp -> prPrec i 1 (concatD [doc (showString "\955"), prt 0 pattern_, doc (showString ":"), prt 0 type_, doc (showString "."), prt 0 scopedexp]) + HM.Parser.Abs.EApp exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, prt 1 exp2]) instance Print HM.Parser.Abs.ScopedExp where prt i = \case diff --git a/src/HM/Parser/Skel.hs b/src/HM/Parser/Skel.hs index f6fb98d..a3cdae1 100644 --- a/src/HM/Parser/Skel.hs +++ b/src/HM/Parser/Skel.hs @@ -35,8 +35,8 @@ transExp x = case x of HM.Parser.Abs.EIsZero exp -> failure x HM.Parser.Abs.ETyped exp type_ -> failure x HM.Parser.Abs.ELet pattern_ exp scopedexp -> failure x - HM.Parser.Abs.EAbs ident type_ exp -> failure x - HM.Parser.Abs.EApp exp1 type_ exp2 -> failure x + HM.Parser.Abs.EAbs pattern_ type_ scopedexp -> failure x + HM.Parser.Abs.EApp exp1 exp2 -> failure x transScopedExp :: HM.Parser.Abs.ScopedExp -> Result transScopedExp x = case x of diff --git a/src/HM/Syntax.hs b/src/HM/Syntax.hs index 895550b..7c26dae 100644 --- a/src/HM/Syntax.hs +++ b/src/HM/Syntax.hs @@ -1,22 +1,23 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} + module HM.Syntax where -import qualified Control.Monad.Foil as Foil -import Control.Monad.Free.Foil -import Control.Monad.Free.Foil.TH -import Data.Bifunctor.TH -import Data.Map (Map) -import qualified Data.Map as Map -import Data.String (IsString (..)) -import qualified HM.Parser.Abs as Raw -import qualified HM.Parser.Par as Raw -import qualified HM.Parser.Print as Raw +import qualified Control.Monad.Foil as Foil +import Control.Monad.Free.Foil +import Control.Monad.Free.Foil.TH +import Data.Bifunctor.TH +import Data.Map (Map) +import qualified Data.Map as Map +import Data.String (IsString (..)) +import qualified HM.Parser.Abs as Raw +import qualified HM.Parser.Par as Raw +import qualified HM.Parser.Print as Raw -- $setup -- >>> :set -XOverloadedStrings @@ -28,6 +29,7 @@ import qualified HM.Parser.Print as Raw -- * Generated code -- ** Signature + mkSignature ''Raw.Exp ''Raw.Ident ''Raw.ScopedExp ''Raw.Pattern deriveZipMatch ''ExpSig deriveBifunctor ''ExpSig @@ -35,6 +37,7 @@ deriveBifoldable ''ExpSig deriveBitraversable ''ExpSig -- ** Pattern synonyms + mkPatternSynonyms ''ExpSig {-# COMPLETE Var, ETrue, EFalse, ENat, EAdd, ESub, EIf, EIsZero, ETyped, ELet #-} @@ -52,7 +55,7 @@ type Exp n = AST ExpSig n -- | Convert 'Raw.Exp' into a scope-safe expression. -- This is a special case of 'convertToAST'. -toExp :: Foil.Distinct n => Foil.Scope n -> Map Raw.Ident (Foil.Name n) -> Raw.Exp -> AST ExpSig n +toExp :: (Foil.Distinct n) => Foil.Scope n -> Map Raw.Ident (Foil.Name n) -> Raw.Exp -> AST ExpSig n toExp = convertToAST convertToExpSig getPatternBinder getExpFromScopedExp -- | Convert 'Raw.Exp' into a closed scope-safe expression. @@ -67,12 +70,13 @@ toExpClosed = toExp Foil.emptyScope Map.empty -- -- This function does not recover location information for variables, patterns, or scoped terms. fromExp :: Exp n -> Raw.Exp -fromExp = convertFromAST - convertFromExpSig - Raw.EVar - Raw.PatternVar - Raw.ScopedExp - (\n -> Raw.Ident ("x" ++ show n)) +fromExp = + convertFromAST + convertFromExpSig + Raw.EVar + Raw.PatternVar + Raw.ScopedExp + (\n -> Raw.Ident ("x" ++ show n)) -- | Parse scope-safe terms via raw representation. -- @@ -80,9 +84,9 @@ fromExp = convertFromAST -- let x0 = 2 + 2 in let x1 = x0 - 1 in let x2 = 3 in x1 + x2 + x1 instance IsString (Exp Foil.VoidS) where fromString input = case Raw.pExp (Raw.myLexer input) of - Left err -> error ("could not parse expression: " <> input <> "\n " <> err) + Left err -> error ("could not parse expression: " <> input <> "\n " <> err) Right term -> toExpClosed term --- | Pretty-print scope-safe terms via raw representation. +-- | Pretty-print scope-safe terms via"λ" Ident ":" Type "." Exp1 raw representation. instance Show (Exp n) where show = Raw.printTree . fromExp diff --git a/src/HM/Typecheck.hs b/src/HM/Typecheck.hs index 414c8e3..2c3b6da 100644 --- a/src/HM/Typecheck.hs +++ b/src/HM/Typecheck.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} module HM.Typecheck where @@ -47,14 +48,10 @@ typecheck scope e expectedType = do ] inferType :: NameMap n Type -> Exp n -> Either String Type +inferType scope (FreeFoil.Var n) = Right (lookupName n scope) -- Γ, x : T ⊢ x : T inferType _scope ETrue = return TBool inferType _scope EFalse = return TBool inferType _scope (ENat _) = return TNat -inferType scope (EIf eCond eThen eElse) = do - _ <- typecheck scope eCond TBool - typeOfThen <- inferType scope eThen - _ <- typecheck scope eElse typeOfThen - return typeOfThen inferType scope (EAdd l r) = do _ <- typecheck scope l TNat _ <- typecheck scope r TNat @@ -63,16 +60,30 @@ inferType scope (ESub l r) = do _ <- typecheck scope l TNat _ <- typecheck scope r TNat return TNat +inferType scope (EIf eCond eThen eElse) = do + _ <- typecheck scope eCond TBool + typeOfThen <- inferType scope eThen + _ <- typecheck scope eElse typeOfThen + return typeOfThen inferType scope (EIsZero e) = do _ <- typecheck scope e TNat return TBool +inferType scope (ETyped expr type_) = do + typecheck scope expr type_ inferType scope (ELet e1 x e2) = do -- Γ ⊢ let x = e1 in e2 : ? type1 <- inferType scope e1 -- Γ ⊢ e1 : type1 let newScope = addNameBinder x type1 scope -- Γ' = Γ, x : type1 inferType newScope e2 -- Γ' ⊢ e2 : ? -inferType scope (ETyped expr type_) = do - typecheck scope expr type_ -inferType scope (FreeFoil.Var n) = Right (lookupName n scope) -- Γ, x : T ⊢ x : T -inferType scope (EApp e1 _ e2) = undefined -inferType scope (EAbs x type_ e) = undefined \ No newline at end of file +inferType scope (EAbs type_ x e) = do + -- Γ ⊢ λx : type_. e : ? + let newScope = addNameBinder x type_ scope -- Γ' = Γ, x : type_ + TArrow type_ <$> inferType newScope e +inferType scope (EApp e1 e2) = do + -- (Γ ⊢ e1) (Γ ⊢ e2) : ? + type1 <- inferType scope e1 -- Γ ⊢ e1 : type1 + case type1 of + TArrow type_ types -> do + _ <- typecheck scope e2 type_ + return types + _ -> Left ("expected type\n TArrow\nbut got type\n " <> show type1) \ No newline at end of file From 8364d67680f849ad4427e29d36a80dc0c9f9ace0 Mon Sep 17 00:00:00 2001 From: frog-da <84839431+frog-da@users.noreply.github.com> Date: Wed, 28 Aug 2024 21:01:25 +0300 Subject: [PATCH 3/8] Error fixed --- src/HM/Parser/Abs.hs | 34 +- src/HM/Parser/Par.hs | 1272 +++++++++++++++++++++------------------- src/HM/Parser/Print.hs | 157 ++--- 3 files changed, 771 insertions(+), 692 deletions(-) diff --git a/src/HM/Parser/Abs.hs b/src/HM/Parser/Abs.hs index dcff1da..dd85112 100644 --- a/src/HM/Parser/Abs.hs +++ b/src/HM/Parser/Abs.hs @@ -1,36 +1,33 @@ -- File generated by the BNF Converter (bnfc 2.9.5). - {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | The abstract syntax of language Parser. - module HM.Parser.Abs where -import Prelude (Integer, String) -import qualified Prelude as C (Eq, Ord, Show, Read) +import qualified Data.Data as C (Data, Typeable) import qualified Data.String - -import qualified Data.Data as C (Data, Typeable) import qualified GHC.Generics as C (Generic) +import Prelude (Integer, String) +import qualified Prelude as C (Eq, Ord, Read, Show) data Pattern = PatternVar Ident deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data Exp - = EVar Ident - | ETrue - | EFalse - | ENat Integer - | EAdd Exp Exp - | ESub Exp Exp - | EIf Exp Exp Exp - | EIsZero Exp - | ETyped Exp Type - | ELet Pattern Exp ScopedExp - | EAbs Pattern Type ScopedExp - | EApp Exp Exp + = EVar Ident + | ETrue + | EFalse + | ENat Integer + | EAdd Exp Exp + | ESub Exp Exp + | EIf Exp Exp Exp + | EIsZero Exp + | ETyped Exp Type + | ELet Pattern Exp ScopedExp + | EAbs Pattern Type ScopedExp + | EApp Exp Exp deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data ScopedExp = ScopedExp Exp @@ -41,4 +38,3 @@ data Type = TNat | TBool | TArrow Type Type newtype Ident = Ident String deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic, Data.String.IsString) - diff --git a/src/HM/Parser/Par.hs b/src/HM/Parser/Par.hs index dd374ec..559fd8d 100644 --- a/src/HM/Parser/Par.hs +++ b/src/HM/Parser/Par.hs @@ -1,39 +1,39 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} {-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} +{-# OPTIONS_GHC -w #-} module HM.Parser.Par - ( happyError - , myLexer - , pPattern - , pExp3 - , pExp2 - , pExp1 - , pExp - , pScopedExp - , pType - ) where - -import Prelude - -import qualified HM.Parser.Abs -import HM.Parser.Lex + ( happyError, + myLexer, + pPattern, + pExp3, + pExp2, + pExp1, + pExp, + pScopedExp, + pType, + ) +where + +import Control.Applicative (Applicative (..)) +import Control.Monad (ap) import qualified Data.Array as Happy_Data_Array import qualified Data.Bits as Bits -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) +import qualified HM.Parser.Abs +import HM.Parser.Lex +import Prelude -- parser produced by Happy Version 1.20.1.1 -data HappyAbsSyn - = HappyTerminal (Token) - | HappyErrorToken Prelude.Int - | HappyAbsSyn10 (HM.Parser.Abs.Ident) - | HappyAbsSyn11 (Integer) - | HappyAbsSyn12 (HM.Parser.Abs.Pattern) - | HappyAbsSyn13 (HM.Parser.Abs.Exp) - | HappyAbsSyn17 (HM.Parser.Abs.ScopedExp) - | HappyAbsSyn18 (HM.Parser.Abs.Type) +data HappyAbsSyn + = HappyTerminal (Token) + | HappyErrorToken Prelude.Int + | HappyAbsSyn10 (HM.Parser.Abs.Ident) + | HappyAbsSyn11 (Integer) + | HappyAbsSyn12 (HM.Parser.Abs.Pattern) + | HappyAbsSyn13 (HM.Parser.Abs.Exp) + | HappyAbsSyn17 (HM.Parser.Abs.ScopedExp) + | HappyAbsSyn18 (HM.Parser.Abs.Type) {- to allow type-synonyms as our monads (likely - with explicitly-specified bind and return) @@ -41,130 +41,297 @@ data HappyAbsSyn - /type M a = .../, then /(HappyReduction M)/ - is not allowed. But Happy is a - code-generator that can just substitute it. -type HappyReduction m = - Prelude.Int +type HappyReduction m = + Prelude.Int -> (Token) -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] - -> HappyStk HappyAbsSyn + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] + -> HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn -} action_0, - action_1, - action_2, - action_3, - action_4, - action_5, - action_6, - action_7, - action_8, - action_9, - action_10, - action_11, - action_12, - action_13, - action_14, - action_15, - action_16, - action_17, - action_18, - action_19, - action_20, - action_21, - action_22, - action_23, - action_24, - action_25, - action_26, - action_27, - action_28, - action_29, - action_30, - action_31, - action_32, - action_33, - action_34, - action_35, - action_36, - action_37, - action_38, - action_39, - action_40, - action_41, - action_42, - action_43, - action_44, - action_45, - action_46, - action_47, - action_48, - action_49, - action_50, - action_51, - action_52, - action_53, - action_54, - action_55, - action_56, - action_57, - action_58, - action_59, - action_60, - action_61 :: () => Prelude.Int -> ({-HappyReduction (Err) = -} - Prelude.Int - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> (Err) HappyAbsSyn) - + action_1, + action_2, + action_3, + action_4, + action_5, + action_6, + action_7, + action_8, + action_9, + action_10, + action_11, + action_12, + action_13, + action_14, + action_15, + action_16, + action_17, + action_18, + action_19, + action_20, + action_21, + action_22, + action_23, + action_24, + action_25, + action_26, + action_27, + action_28, + action_29, + action_30, + action_31, + action_32, + action_33, + action_34, + action_35, + action_36, + action_37, + action_38, + action_39, + action_40, + action_41, + action_42, + action_43, + action_44, + action_45, + action_46, + action_47, + action_48, + action_49, + action_50, + action_51, + action_52, + action_53, + action_54, + action_55, + action_56, + action_57, + action_58, + action_59, + action_60, + action_61 :: + () => + Prelude.Int -> + ( {-HappyReduction (Err) = -} + Prelude.Int -> + (Token) -> + HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) -> + [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] -> + HappyStk HappyAbsSyn -> + [(Token)] -> + (Err) HappyAbsSyn + ) happyReduce_7, - happyReduce_8, - happyReduce_9, - happyReduce_10, - happyReduce_11, - happyReduce_12, - happyReduce_13, - happyReduce_14, - happyReduce_15, - happyReduce_16, - happyReduce_17, - happyReduce_18, - happyReduce_19, - happyReduce_20, - happyReduce_21, - happyReduce_22, - happyReduce_23, - happyReduce_24, - happyReduce_25, - happyReduce_26, - happyReduce_27, - happyReduce_28, - happyReduce_29 :: () => ({-HappyReduction (Err) = -} - Prelude.Int - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> (Err) HappyAbsSyn) - + happyReduce_8, + happyReduce_9, + happyReduce_10, + happyReduce_11, + happyReduce_12, + happyReduce_13, + happyReduce_14, + happyReduce_15, + happyReduce_16, + happyReduce_17, + happyReduce_18, + happyReduce_19, + happyReduce_20, + happyReduce_21, + happyReduce_22, + happyReduce_23, + happyReduce_24, + happyReduce_25, + happyReduce_26, + happyReduce_27, + happyReduce_28, + happyReduce_29 :: + () => + ( {-HappyReduction (Err) = -} + Prelude.Int -> + (Token) -> + HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) -> + [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] -> + HappyStk HappyAbsSyn -> + [(Token)] -> + (Err) HappyAbsSyn + ) happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int -happyExpList = Happy_Data_Array.listArray (0,232) ([0,0,32,1024,26656,0,8196,105,1024,31584,0,24580,123,1024,31584,0,3072,0,0,8192,0,0,0,16384,0,0,0,0,0,0,0,0,0,0,0,0,0,0,12288,0,0,0,0,0,0,0,24580,123,0,0,0,24580,123,1024,0,0,0,32,0,0,0,0,32,0,0,0,24836,123,0,0,0,24580,123,12288,0,0,0,0,0,0,0,0,0,1024,26656,0,8196,104,0,0,0,3072,0,0,1,0,512,0,1024,31584,0,24580,127,2048,0,0,3072,0,0,0,0,0,0,1024,31584,0,8,0,1024,31584,0,3072,0,16384,0,0,0,0,0,0,0,192,0,1024,31712,0,0,0,1024,31600,0,24580,123,1024,31584,0,24580,123,0,0,0,0,0,0,0,0 - ]) +happyExpList = + Happy_Data_Array.listArray + (0, 232) + ( [ 0, + 0, + 32, + 1024, + 26656, + 0, + 8196, + 105, + 1024, + 31584, + 0, + 24580, + 123, + 1024, + 31584, + 0, + 3072, + 0, + 0, + 8192, + 0, + 0, + 0, + 16384, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 12288, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 24580, + 123, + 0, + 0, + 0, + 24580, + 123, + 1024, + 0, + 0, + 0, + 32, + 0, + 0, + 0, + 0, + 32, + 0, + 0, + 0, + 24836, + 123, + 0, + 0, + 0, + 24580, + 123, + 12288, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 1024, + 26656, + 0, + 8196, + 104, + 0, + 0, + 0, + 3072, + 0, + 0, + 1, + 0, + 512, + 0, + 1024, + 31584, + 0, + 24580, + 127, + 2048, + 0, + 0, + 3072, + 0, + 0, + 0, + 0, + 0, + 0, + 1024, + 31584, + 0, + 8, + 0, + 1024, + 31584, + 0, + 3072, + 0, + 16384, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 192, + 0, + 1024, + 31712, + 0, + 0, + 0, + 1024, + 31600, + 0, + 24580, + 123, + 1024, + 31584, + 0, + 24580, + 123, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0 + ] + ) {-# NOINLINE happyExpListPerState #-} happyExpListPerState st = - token_strs_expected - where token_strs = ["error","%dummy","%start_pPattern","%start_pExp3","%start_pExp2","%start_pExp1","%start_pExp","%start_pScopedExp","%start_pType","Ident","Integer","Pattern","Exp3","Exp2","Exp1","Exp","ScopedExp","Type","'('","')'","'+'","'-'","'->'","'.'","':'","'='","'Bool'","'Nat'","'else'","'false'","'if'","'in'","'iszero'","'let'","'then'","'true'","'\955'","L_Ident","L_integ","%eof"] - bit_start = st Prelude.* 40 - bit_end = (st Prelude.+ 1) Prelude.* 40 - read_bit = readArrayBit happyExpList - bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] - bits_indexed = Prelude.zip bits [0..39] - token_strs_expected = Prelude.concatMap f bits_indexed - f (Prelude.False, _) = [] - f (Prelude.True, nr) = [token_strs Prelude.!! nr] + token_strs_expected + where + token_strs = ["error", "%dummy", "%start_pPattern", "%start_pExp3", "%start_pExp2", "%start_pExp1", "%start_pExp", "%start_pScopedExp", "%start_pType", "Ident", "Integer", "Pattern", "Exp3", "Exp2", "Exp1", "Exp", "ScopedExp", "Type", "'('", "')'", "'+'", "'-'", "'->'", "'.'", "':'", "'='", "'Bool'", "'Nat'", "'else'", "'false'", "'if'", "'in'", "'iszero'", "'let'", "'then'", "'true'", "'\955'", "L_Ident", "L_integ", "%eof"] + bit_start = st Prelude.* 40 + bit_end = (st Prelude.+ 1) Prelude.* 40 + read_bit = readArrayBit happyExpList + bits = Prelude.map read_bit [bit_start .. bit_end Prelude.- 1] + bits_indexed = Prelude.zip bits [0 .. 39] + token_strs_expected = Prelude.concatMap f bits_indexed + f (Prelude.False, _) = [] + f (Prelude.True, nr) = [token_strs Prelude.!! nr] action_0 (38) = happyShift action_8 action_0 (10) = happyGoto action_31 @@ -643,356 +810,329 @@ action_61 (14) = happyGoto action_15 action_61 (15) = happyGoto action_35 action_61 _ = happyReduce_19 -happyReduce_7 = happySpecReduce_1 10 happyReduction_7 -happyReduction_7 (HappyTerminal (PT _ (TV happy_var_1))) - = HappyAbsSyn10 - (HM.Parser.Abs.Ident happy_var_1 - ) -happyReduction_7 _ = notHappyAtAll - -happyReduce_8 = happySpecReduce_1 11 happyReduction_8 -happyReduction_8 (HappyTerminal (PT _ (TI happy_var_1))) - = HappyAbsSyn11 - ((read happy_var_1) :: Integer - ) -happyReduction_8 _ = notHappyAtAll - -happyReduce_9 = happySpecReduce_1 12 happyReduction_9 -happyReduction_9 (HappyAbsSyn10 happy_var_1) - = HappyAbsSyn12 - (HM.Parser.Abs.PatternVar happy_var_1 - ) -happyReduction_9 _ = notHappyAtAll - -happyReduce_10 = happySpecReduce_1 13 happyReduction_10 -happyReduction_10 (HappyAbsSyn10 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.EVar happy_var_1 - ) -happyReduction_10 _ = notHappyAtAll - -happyReduce_11 = happySpecReduce_1 13 happyReduction_11 -happyReduction_11 _ - = HappyAbsSyn13 - (HM.Parser.Abs.ETrue - ) - -happyReduce_12 = happySpecReduce_1 13 happyReduction_12 -happyReduction_12 _ - = HappyAbsSyn13 - (HM.Parser.Abs.EFalse - ) - -happyReduce_13 = happySpecReduce_1 13 happyReduction_13 -happyReduction_13 (HappyAbsSyn11 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.ENat happy_var_1 - ) -happyReduction_13 _ = notHappyAtAll - -happyReduce_14 = happySpecReduce_3 13 happyReduction_14 -happyReduction_14 _ - (HappyAbsSyn13 happy_var_2) - _ - = HappyAbsSyn13 - (happy_var_2 - ) -happyReduction_14 _ _ _ = notHappyAtAll - -happyReduce_15 = happySpecReduce_3 14 happyReduction_15 -happyReduction_15 (HappyAbsSyn13 happy_var_3) - _ - (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.EAdd happy_var_1 happy_var_3 - ) -happyReduction_15 _ _ _ = notHappyAtAll - -happyReduce_16 = happySpecReduce_3 14 happyReduction_16 -happyReduction_16 (HappyAbsSyn13 happy_var_3) - _ - (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.ESub happy_var_1 happy_var_3 - ) -happyReduction_16 _ _ _ = notHappyAtAll +happyReduce_7 = happySpecReduce_1 10 happyReduction_7 + +happyReduction_7 (HappyTerminal (PT _ (TV happy_var_1))) = + HappyAbsSyn10 + ( HM.Parser.Abs.Ident happy_var_1 + ) +happyReduction_7 _ = notHappyAtAll + +happyReduce_8 = happySpecReduce_1 11 happyReduction_8 + +happyReduction_8 (HappyTerminal (PT _ (TI happy_var_1))) = + HappyAbsSyn11 + ( (read happy_var_1) :: Integer + ) +happyReduction_8 _ = notHappyAtAll + +happyReduce_9 = happySpecReduce_1 12 happyReduction_9 + +happyReduction_9 (HappyAbsSyn10 happy_var_1) = + HappyAbsSyn12 + ( HM.Parser.Abs.PatternVar happy_var_1 + ) +happyReduction_9 _ = notHappyAtAll + +happyReduce_10 = happySpecReduce_1 13 happyReduction_10 + +happyReduction_10 (HappyAbsSyn10 happy_var_1) = + HappyAbsSyn13 + ( HM.Parser.Abs.EVar happy_var_1 + ) +happyReduction_10 _ = notHappyAtAll + +happyReduce_11 = happySpecReduce_1 13 happyReduction_11 + +happyReduction_11 _ = + HappyAbsSyn13 + ( HM.Parser.Abs.ETrue + ) + +happyReduce_12 = happySpecReduce_1 13 happyReduction_12 + +happyReduction_12 _ = + HappyAbsSyn13 + ( HM.Parser.Abs.EFalse + ) + +happyReduce_13 = happySpecReduce_1 13 happyReduction_13 + +happyReduction_13 (HappyAbsSyn11 happy_var_1) = + HappyAbsSyn13 + ( HM.Parser.Abs.ENat happy_var_1 + ) +happyReduction_13 _ = notHappyAtAll + +happyReduce_14 = happySpecReduce_3 13 happyReduction_14 + +happyReduction_14 + _ + (HappyAbsSyn13 happy_var_2) + _ = + HappyAbsSyn13 + ( happy_var_2 + ) +happyReduction_14 _ _ _ = notHappyAtAll + +happyReduce_15 = happySpecReduce_3 14 happyReduction_15 + +happyReduction_15 + (HappyAbsSyn13 happy_var_3) + _ + (HappyAbsSyn13 happy_var_1) = + HappyAbsSyn13 + ( HM.Parser.Abs.EAdd happy_var_1 happy_var_3 + ) +happyReduction_15 _ _ _ = notHappyAtAll + +happyReduce_16 = happySpecReduce_3 14 happyReduction_16 + +happyReduction_16 + (HappyAbsSyn13 happy_var_3) + _ + (HappyAbsSyn13 happy_var_1) = + HappyAbsSyn13 + ( HM.Parser.Abs.ESub happy_var_1 happy_var_3 + ) +happyReduction_16 _ _ _ = notHappyAtAll happyReduce_17 = happyReduce 4 14 happyReduction_17 -happyReduction_17 (_ `HappyStk` - (HappyAbsSyn13 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn13 - (HM.Parser.Abs.EIsZero happy_var_3 - ) `HappyStk` happyRest - -happyReduce_18 = happySpecReduce_1 14 happyReduction_18 -happyReduction_18 (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (happy_var_1 - ) -happyReduction_18 _ = notHappyAtAll + +happyReduction_17 + ( _ + `HappyStk` (HappyAbsSyn13 happy_var_3) + `HappyStk` _ + `HappyStk` _ + `HappyStk` happyRest + ) = + HappyAbsSyn13 + ( HM.Parser.Abs.EIsZero happy_var_3 + ) + `HappyStk` happyRest + +happyReduce_18 = happySpecReduce_1 14 happyReduction_18 + +happyReduction_18 (HappyAbsSyn13 happy_var_1) = + HappyAbsSyn13 + ( happy_var_1 + ) +happyReduction_18 _ = notHappyAtAll happyReduce_19 = happyReduce 6 15 happyReduction_19 -happyReduction_19 ((HappyAbsSyn13 happy_var_6) `HappyStk` - _ `HappyStk` - (HappyAbsSyn13 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn13 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn13 - (HM.Parser.Abs.EIf happy_var_2 happy_var_4 happy_var_6 - ) `HappyStk` happyRest + +happyReduction_19 + ( (HappyAbsSyn13 happy_var_6) + `HappyStk` _ + `HappyStk` (HappyAbsSyn13 happy_var_4) + `HappyStk` _ + `HappyStk` (HappyAbsSyn13 happy_var_2) + `HappyStk` _ + `HappyStk` happyRest + ) = + HappyAbsSyn13 + ( HM.Parser.Abs.EIf happy_var_2 happy_var_4 happy_var_6 + ) + `HappyStk` happyRest happyReduce_20 = happyReduce 6 15 happyReduction_20 -happyReduction_20 ((HappyAbsSyn17 happy_var_6) `HappyStk` - _ `HappyStk` - (HappyAbsSyn13 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn13 - (HM.Parser.Abs.ELet happy_var_2 happy_var_4 happy_var_6 - ) `HappyStk` happyRest + +happyReduction_20 + ( (HappyAbsSyn17 happy_var_6) + `HappyStk` _ + `HappyStk` (HappyAbsSyn13 happy_var_4) + `HappyStk` _ + `HappyStk` (HappyAbsSyn12 happy_var_2) + `HappyStk` _ + `HappyStk` happyRest + ) = + HappyAbsSyn13 + ( HM.Parser.Abs.ELet happy_var_2 happy_var_4 happy_var_6 + ) + `HappyStk` happyRest happyReduce_21 = happyReduce 6 15 happyReduction_21 -happyReduction_21 ((HappyAbsSyn17 happy_var_6) `HappyStk` - _ `HappyStk` - (HappyAbsSyn18 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn13 - (HM.Parser.Abs.EAbs happy_var_2 happy_var_4 happy_var_6 - ) `HappyStk` happyRest - -happyReduce_22 = happySpecReduce_2 15 happyReduction_22 -happyReduction_22 (HappyAbsSyn13 happy_var_2) - (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.EApp happy_var_1 happy_var_2 - ) -happyReduction_22 _ _ = notHappyAtAll - -happyReduce_23 = happySpecReduce_1 15 happyReduction_23 -happyReduction_23 (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (happy_var_1 - ) -happyReduction_23 _ = notHappyAtAll - -happyReduce_24 = happySpecReduce_3 16 happyReduction_24 -happyReduction_24 (HappyAbsSyn18 happy_var_3) - _ - (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (HM.Parser.Abs.ETyped happy_var_1 happy_var_3 - ) -happyReduction_24 _ _ _ = notHappyAtAll - -happyReduce_25 = happySpecReduce_1 16 happyReduction_25 -happyReduction_25 (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn13 - (happy_var_1 - ) -happyReduction_25 _ = notHappyAtAll - -happyReduce_26 = happySpecReduce_1 17 happyReduction_26 -happyReduction_26 (HappyAbsSyn13 happy_var_1) - = HappyAbsSyn17 - (HM.Parser.Abs.ScopedExp happy_var_1 - ) -happyReduction_26 _ = notHappyAtAll - -happyReduce_27 = happySpecReduce_1 18 happyReduction_27 -happyReduction_27 _ - = HappyAbsSyn18 - (HM.Parser.Abs.TNat - ) - -happyReduce_28 = happySpecReduce_1 18 happyReduction_28 -happyReduction_28 _ - = HappyAbsSyn18 - (HM.Parser.Abs.TBool - ) - -happyReduce_29 = happySpecReduce_3 18 happyReduction_29 -happyReduction_29 (HappyAbsSyn18 happy_var_3) - _ - (HappyAbsSyn18 happy_var_1) - = HappyAbsSyn18 - (HM.Parser.Abs.TArrow happy_var_1 happy_var_3 - ) -happyReduction_29 _ _ _ = notHappyAtAll + +happyReduction_21 + ( (HappyAbsSyn17 happy_var_6) + `HappyStk` _ + `HappyStk` (HappyAbsSyn18 happy_var_4) + `HappyStk` _ + `HappyStk` (HappyAbsSyn12 happy_var_2) + `HappyStk` _ + `HappyStk` happyRest + ) = + HappyAbsSyn13 + ( HM.Parser.Abs.EAbs happy_var_2 happy_var_4 happy_var_6 + ) + `HappyStk` happyRest + +happyReduce_22 = happySpecReduce_2 15 happyReduction_22 + +happyReduction_22 + (HappyAbsSyn13 happy_var_2) + (HappyAbsSyn13 happy_var_1) = + HappyAbsSyn13 + ( HM.Parser.Abs.EApp happy_var_1 happy_var_2 + ) +happyReduction_22 _ _ = notHappyAtAll + +happyReduce_23 = happySpecReduce_1 15 happyReduction_23 + +happyReduction_23 (HappyAbsSyn13 happy_var_1) = + HappyAbsSyn13 + ( happy_var_1 + ) +happyReduction_23 _ = notHappyAtAll + +happyReduce_24 = happySpecReduce_3 16 happyReduction_24 + +happyReduction_24 + (HappyAbsSyn18 happy_var_3) + _ + (HappyAbsSyn13 happy_var_1) = + HappyAbsSyn13 + ( HM.Parser.Abs.ETyped happy_var_1 happy_var_3 + ) +happyReduction_24 _ _ _ = notHappyAtAll + +happyReduce_25 = happySpecReduce_1 16 happyReduction_25 + +happyReduction_25 (HappyAbsSyn13 happy_var_1) = + HappyAbsSyn13 + ( happy_var_1 + ) +happyReduction_25 _ = notHappyAtAll + +happyReduce_26 = happySpecReduce_1 17 happyReduction_26 + +happyReduction_26 (HappyAbsSyn13 happy_var_1) = + HappyAbsSyn17 + ( HM.Parser.Abs.ScopedExp happy_var_1 + ) +happyReduction_26 _ = notHappyAtAll + +happyReduce_27 = happySpecReduce_1 18 happyReduction_27 + +happyReduction_27 _ = + HappyAbsSyn18 + ( HM.Parser.Abs.TNat + ) + +happyReduce_28 = happySpecReduce_1 18 happyReduction_28 + +happyReduction_28 _ = + HappyAbsSyn18 + ( HM.Parser.Abs.TBool + ) + +happyReduce_29 = happySpecReduce_3 18 happyReduction_29 + +happyReduction_29 + (HappyAbsSyn18 happy_var_3) + _ + (HappyAbsSyn18 happy_var_1) = + HappyAbsSyn18 + ( HM.Parser.Abs.TArrow happy_var_1 happy_var_3 + ) +happyReduction_29 _ _ _ = notHappyAtAll happyNewToken action sts stk [] = - action 40 40 notHappyAtAll (HappyState action) sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = action i i tk (HappyState action) sts stk tks in - case tk of { - PT _ (TS _ 1) -> cont 19; - PT _ (TS _ 2) -> cont 20; - PT _ (TS _ 3) -> cont 21; - PT _ (TS _ 4) -> cont 22; - PT _ (TS _ 5) -> cont 23; - PT _ (TS _ 6) -> cont 24; - PT _ (TS _ 7) -> cont 25; - PT _ (TS _ 8) -> cont 26; - PT _ (TS _ 9) -> cont 27; - PT _ (TS _ 10) -> cont 28; - PT _ (TS _ 11) -> cont 29; - PT _ (TS _ 12) -> cont 30; - PT _ (TS _ 13) -> cont 31; - PT _ (TS _ 14) -> cont 32; - PT _ (TS _ 15) -> cont 33; - PT _ (TS _ 16) -> cont 34; - PT _ (TS _ 17) -> cont 35; - PT _ (TS _ 18) -> cont 36; - PT _ (TS _ 19) -> cont 37; - PT _ (TV happy_dollar_dollar) -> cont 38; - PT _ (TI happy_dollar_dollar) -> cont 39; - _ -> happyError' ((tk:tks), []) - } + action 40 40 notHappyAtAll (HappyState action) sts stk [] +happyNewToken action sts stk (tk : tks) = + let cont i = action i i tk (HappyState action) sts stk tks + in case tk of + PT _ (TS _ 1) -> cont 19 + PT _ (TS _ 2) -> cont 20 + PT _ (TS _ 3) -> cont 21 + PT _ (TS _ 4) -> cont 22 + PT _ (TS _ 5) -> cont 23 + PT _ (TS _ 6) -> cont 24 + PT _ (TS _ 7) -> cont 25 + PT _ (TS _ 8) -> cont 26 + PT _ (TS _ 9) -> cont 27 + PT _ (TS _ 10) -> cont 28 + PT _ (TS _ 11) -> cont 29 + PT _ (TS _ 12) -> cont 30 + PT _ (TS _ 13) -> cont 31 + PT _ (TS _ 14) -> cont 32 + PT _ (TS _ 15) -> cont 33 + PT _ (TS _ 16) -> cont 34 + PT _ (TS _ 17) -> cont 35 + PT _ (TS _ 18) -> cont 36 + PT _ (TS _ 19) -> cont 37 + PT _ (TV happy_dollar_dollar) -> cont 38 + PT _ (TI happy_dollar_dollar) -> cont 39 + _ -> happyError' ((tk : tks), []) happyError_ explist 40 tk tks = happyError' (tks, explist) -happyError_ explist _ tk tks = happyError' ((tk:tks), explist) +happyError_ explist _ tk tks = happyError' ((tk : tks), explist) happyThen :: () => Err a -> (a -> Err b) -> Err b happyThen = ((>>=)) + happyReturn :: () => a -> Err a happyReturn = (return) + happyThen1 m k tks = ((>>=)) m (\a -> k a tks) + happyReturn1 :: () => a -> b -> Err a happyReturn1 = \a tks -> (return) a + happyError' :: () => ([(Token)], [Prelude.String]) -> Err a happyError' = (\(tokens, _) -> happyError tokens) -pPattern tks = happySomeParser where - happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn12 z -> happyReturn z; _other -> notHappyAtAll }) -pExp3 tks = happySomeParser where - happySomeParser = happyThen (happyParse action_1 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) +pPattern tks = happySomeParser + where + happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of HappyAbsSyn12 z -> happyReturn z; _other -> notHappyAtAll) -pExp2 tks = happySomeParser where - happySomeParser = happyThen (happyParse action_2 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) +pExp3 tks = happySomeParser + where + happySomeParser = happyThen (happyParse action_1 tks) (\x -> case x of HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll) -pExp1 tks = happySomeParser where - happySomeParser = happyThen (happyParse action_3 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) +pExp2 tks = happySomeParser + where + happySomeParser = happyThen (happyParse action_2 tks) (\x -> case x of HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll) -pExp tks = happySomeParser where - happySomeParser = happyThen (happyParse action_4 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) +pExp1 tks = happySomeParser + where + happySomeParser = happyThen (happyParse action_3 tks) (\x -> case x of HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll) -pScopedExp tks = happySomeParser where - happySomeParser = happyThen (happyParse action_5 tks) (\x -> case x of {HappyAbsSyn17 z -> happyReturn z; _other -> notHappyAtAll }) +pExp tks = happySomeParser + where + happySomeParser = happyThen (happyParse action_4 tks) (\x -> case x of HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll) -pType tks = happySomeParser where - happySomeParser = happyThen (happyParse action_6 tks) (\x -> case x of {HappyAbsSyn18 z -> happyReturn z; _other -> notHappyAtAll }) +pScopedExp tks = happySomeParser + where + happySomeParser = happyThen (happyParse action_5 tks) (\x -> case x of HappyAbsSyn17 z -> happyReturn z; _other -> notHappyAtAll) -happySeq = happyDontSeq +pType tks = happySomeParser + where + happySomeParser = happyThen (happyParse action_6 tks) (\x -> case x of HappyAbsSyn18 z -> happyReturn z; _other -> notHappyAtAll) +happySeq = happyDontSeq type Err = Either String happyError :: [Token] -> Err a -happyError ts = Left $ - "syntax error at " ++ tokenPos ts ++ - case ts of - [] -> [] - [Err _] -> " due to lexer error" - t:_ -> " before `" ++ (prToken t) ++ "'" +happyError ts = + Left $ + "syntax error at " + ++ tokenPos ts + ++ case ts of + [] -> [] + [Err _] -> " due to lexer error" + t : _ -> " before `" ++ (prToken t) ++ "'" myLexer :: String -> [Token] myLexer = tokens {-# LINE 1 "templates/GenericTemplate.hs" #-} -- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - data Happy_IntList = HappyCons Prelude.Int Happy_IntList - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - infixr 9 `HappyStk` + data HappyStk a = HappyStk a (HappyStk a) ----------------------------------------------------------------------------- @@ -1007,191 +1147,121 @@ happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll -- parse (a %partial parser). We must ignore the saved token on the top of -- the stack in this case. happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyReturn1 ans) + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyReturn1 ans) ----------------------------------------------------------------------------- -- Arrays only: do the next action - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - indexShortOffAddr arr off = arr Happy_Data_Array.! off - {-# INLINE happyLt #-} happyLt x y = (x Prelude.< y) - - - - - readArrayBit arr bit = - Bits.testBit (indexShortOffAddr arr (bit `Prelude.div` 16)) (bit `Prelude.mod` 16) - - - - - + Bits.testBit (indexShortOffAddr arr (bit `Prelude.div` 16)) (bit `Prelude.mod` 16) ----------------------------------------------------------------------------- -- HappyState data type (not arrays) - - -newtype HappyState b c = HappyState - (Prelude.Int -> -- token number - Prelude.Int -> -- token number (yes, again) - b -> -- token semantic value - HappyState b c -> -- current state - [HappyState b c] -> -- state stack - c) - - +newtype HappyState b c + = HappyState + ( Prelude.Int -> -- token number + Prelude.Int -> -- token number (yes, again) + b -> -- token semantic value + HappyState b c -> -- current state + [HappyState b c] -> -- state stack + c + ) ----------------------------------------------------------------------------- -- Shifting a token happyShift new_state (1) tk st sts stk@(x `HappyStk` _) = - let i = (case x of { HappyErrorToken (i) -> i }) in --- trace "shifting the error token" $ - new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk) - + let i = (case x of HappyErrorToken (i) -> i) + in -- trace "shifting the error token" $ + new_state i i tk (HappyState (new_state)) ((st) : (sts)) (stk) happyShift new_state i tk st sts stk = - happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk) + happyNewToken new_state ((st) : (sts)) ((HappyTerminal (tk)) `HappyStk` stk) -- happyReduce is specialised for the common cases. -happySpecReduce_0 i fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk - = action nt j tk st ((st):(sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Prelude.- ((1) :: Prelude.Int)) sts of - sts1@(((st1@(HappyState (action))):(_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (action nt j tk st1 sts1 r) - -happyMonadReduce k nt fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk +happySpecReduce_0 i fn (1) tk st sts stk = + happyFail [] (1) tk st sts stk +happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk = + action nt j tk st ((st) : (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn (1) tk st sts stk = + happyFail [] (1) tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))) : (_))) (v1 `HappyStk` stk') = + let r = fn v1 + in happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn (1) tk st sts stk = + happyFail [] (1) tk st sts stk +happySpecReduce_2 nt fn j tk _ ((_) : (sts@(((st@(HappyState (action))) : (_))))) (v1 `HappyStk` v2 `HappyStk` stk') = + let r = fn v1 v2 + in happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn (1) tk st sts stk = + happyFail [] (1) tk st sts stk +happySpecReduce_3 nt fn j tk _ ((_) : (((_) : (sts@(((st@(HappyState (action))) : (_))))))) (v1 `HappyStk` v2 `HappyStk` v3 `HappyStk` stk') = + let r = fn v1 v2 v3 + in happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn (1) tk st sts stk = + happyFail [] (1) tk st sts stk +happyReduce k nt fn j tk st sts stk = + case happyDrop (k Prelude.- ((1) :: Prelude.Int)) sts of + sts1@(((st1@(HappyState (action))) : (_))) -> + let r = fn stk -- it doesn't hurt to always seq here... + in happyDoSeq r (action nt j tk st1 sts1 r) + +happyMonadReduce k nt fn (1) tk st sts stk = + happyFail [] (1) tk st sts stk happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k ((st):(sts)) of - sts1@(((st1@(HappyState (action))):(_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) + case happyDrop k ((st) : (sts)) of + sts1@(((st1@(HappyState (action))) : (_))) -> + let drop_stk = happyDropStk k stk + in happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) -happyMonad2Reduce k nt fn (1) tk st sts stk - = happyFail [] (1) tk st sts stk +happyMonad2Reduce k nt fn (1) tk st sts stk = + happyFail [] (1) tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k ((st):(sts)) of - sts1@(((st1@(HappyState (action))):(_))) -> - let drop_stk = happyDropStk k stk + case happyDrop k ((st) : (sts)) of + sts1@(((st1@(HappyState (action))) : (_))) -> + let drop_stk = happyDropStk k stk - - - - - _ = nt :: Prelude.Int - new_state = action - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + _ = nt :: Prelude.Int + new_state = action + in happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) happyDrop (0) l = l -happyDrop n ((_):(t)) = happyDrop (n Prelude.- ((1) :: Prelude.Int)) t +happyDrop n ((_) : (t)) = happyDrop (n Prelude.- ((1) :: Prelude.Int)) t happyDropStk (0) l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Prelude.- ((1)::Prelude.Int)) xs +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Prelude.- ((1) :: Prelude.Int)) xs ----------------------------------------------------------------------------- -- Moving to a new state after a reduction - - - - - - - - happyGoto action j tk st = action j j tk (HappyState action) - ----------------------------------------------------------------------------- -- Error recovery (ERROR_TOK is the error token) -- parse error if we are in recovery and we fail again happyFail explist (1) tk old_st _ stk@(x `HappyStk` _) = - let i = (case x of { HappyErrorToken (i) -> i }) in --- trace "failing" $ - happyError_ explist i tk - + let i = (case x of HappyErrorToken (i) -> i) + in -- trace "failing" $ + happyError_ explist i tk {- We don't need state discarding for our restricted implementation of "error". In fact, it can cause some bogus parses, so I've disabled it for now --SDM -- discard a state -happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) +happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) (saved_tok `HappyStk` _ `HappyStk` stk) = -- trace ("discarding state, depth " ++ show (length stk)) $ DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk)) @@ -1200,8 +1270,8 @@ happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) -- Enter error recovery: generate an error token, -- save the old token and carry on. happyFail explist i tk (HappyState (action)) sts stk = --- trace "entering error recovery" $ - action (1) (1) tk (HappyState (action)) sts ((HappyErrorToken (i)) `HappyStk` stk) + -- trace "entering error recovery" $ + action (1) (1) tk (HappyState (action)) sts ((HappyErrorToken (i)) `HappyStk` stk) -- Internal happy errors: @@ -1211,20 +1281,14 @@ notHappyAtAll = Prelude.error "Internal Happy error\n" ----------------------------------------------------------------------------- -- Hack to get the typechecker to accept our action functions - - - - - - ----------------------------------------------------------------------------- --- Seq-ing. If the --strict flag is given, then Happy emits +-- Seq-ing. If the --strict flag is given, then Happy emits -- happySeq = happyDoSeq -- otherwise it emits -- happySeq = happyDontSeq happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `Prelude.seq` b +happyDoSeq a b = a `Prelude.seq` b happyDontSeq a b = b ----------------------------------------------------------------------------- @@ -1232,22 +1296,22 @@ happyDontSeq a b = b -- of deciding to inline happyGoto everywhere, which increases the size of -- the generated parser quite a bit. - - - - - - - - {-# NOINLINE happyShift #-} + {-# NOINLINE happySpecReduce_0 #-} + {-# NOINLINE happySpecReduce_1 #-} + {-# NOINLINE happySpecReduce_2 #-} + {-# NOINLINE happySpecReduce_3 #-} + {-# NOINLINE happyReduce #-} + {-# NOINLINE happyMonadReduce #-} + {-# NOINLINE happyGoto #-} + {-# NOINLINE happyFail #-} -- end of Happy Template. diff --git a/src/HM/Parser/Print.hs b/src/HM/Parser/Print.hs index 40236d2..1bca676 100644 --- a/src/HM/Parser/Print.hs +++ b/src/HM/Parser/Print.hs @@ -1,5 +1,4 @@ -- File generated by the BNF Converter (bnfc 2.9.5). - {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -8,23 +7,40 @@ #endif -- | Pretty-printer for HM. - module HM.Parser.Print where +import Data.Char (Char, isSpace) +import qualified HM.Parser.Abs import Prelude - ( ($), (.) - , Bool(..), (==), (<) - , Int, Integer, Double, (+), (-), (*) - , String, (++) - , ShowS, showChar, showString - , all, elem, foldr, id, map, null, replicate, shows, span + ( Bool (..), + Double, + Int, + Integer, + ShowS, + String, + all, + elem, + foldr, + id, + map, + null, + replicate, + showChar, + showString, + shows, + span, + ($), + (*), + (+), + (++), + (-), + (.), + (<), + (==), ) -import Data.Char ( Char, isSpace ) -import qualified HM.Parser.Abs -- | The top-level printing method. - -printTree :: Print a => a -> String +printTree :: (Print a) => a -> String printTree = render . prt 0 type Doc = [ShowS] -> [ShowS] @@ -35,61 +51,64 @@ doc = (:) render :: Doc -> String render d = rend 0 False (map ($ "") $ d []) "" where - rend - :: Int -- ^ Indentation level. - -> Bool -- ^ Pending indentation to be output before next character? - -> [String] - -> ShowS - rend i p = \case - "[" :ts -> char '[' . rend i False ts - "(" :ts -> char '(' . rend i False ts - "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts - "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts - "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts - [";"] -> char ';' - ";" :ts -> char ';' . new i ts - t : ts@(s:_) | closingOrPunctuation s - -> pending . showString t . rend i False ts - t :ts -> pending . space t . rend i False ts - [] -> id - where - -- Output character after pending indentation. - char :: Char -> ShowS - char c = pending . showChar c - - -- Output pending indentation. - pending :: ShowS - pending = if p then indent i else id - - -- Indentation (spaces) for given indentation level. - indent :: Int -> ShowS - indent i = replicateS (2*i) (showChar ' ') - - -- Continue rendering in new line with new indentation. - new :: Int -> [String] -> ShowS - new j ts = showChar '\n' . rend j True ts - - -- Make sure we are on a fresh line. - onNewLine :: Int -> Bool -> ShowS - onNewLine i p = (if p then id else showChar '\n') . indent i - - -- Separate given string from following text by a space (if needed). - space :: String -> ShowS - space t s = - case (all isSpace t, null spc, null rest) of - (True , _ , True ) -> [] -- remove trailing space - (False, _ , True ) -> t -- remove trailing space - (False, True, False) -> t ++ ' ' : s -- add space if none - _ -> t ++ s - where - (spc, rest) = span isSpace s - - closingOrPunctuation :: String -> Bool - closingOrPunctuation [c] = c `elem` closerOrPunct - closingOrPunctuation _ = False - - closerOrPunct :: String - closerOrPunct = ")],;" + rend :: + Int -> + -- \^ Indentation level. + Bool -> + -- \^ Pending indentation to be output before next character? + [String] -> + ShowS + rend i p = \case + "[" : ts -> char '[' . rend i False ts + "(" : ts -> char '(' . rend i False ts + "{" : ts -> onNewLine i p . showChar '{' . new (i + 1) ts + "}" : ";" : ts -> onNewLine (i - 1) p . showString "};" . new (i - 1) ts + "}" : ts -> onNewLine (i - 1) p . showChar '}' . new (i - 1) ts + [";"] -> char ';' + ";" : ts -> char ';' . new i ts + t : ts@(s : _) + | closingOrPunctuation s -> + pending . showString t . rend i False ts + t : ts -> pending . space t . rend i False ts + [] -> id + where + -- Output character after pending indentation. + char :: Char -> ShowS + char c = pending . showChar c + + -- Output pending indentation. + pending :: ShowS + pending = if p then indent i else id + + -- Indentation (spaces) for given indentation level. + indent :: Int -> ShowS + indent i = replicateS (2 * i) (showChar ' ') + + -- Continue rendering in new line with new indentation. + new :: Int -> [String] -> ShowS + new j ts = showChar '\n' . rend j True ts + + -- Make sure we are on a fresh line. + onNewLine :: Int -> Bool -> ShowS + onNewLine i p = (if p then id else showChar '\n') . indent i + + -- Separate given string from following text by a space (if needed). + space :: String -> ShowS + space t s = + case (all isSpace t, null spc, null rest) of + (True, _, True) -> [] -- remove trailing space + (False, _, True) -> t -- remove trailing space + (False, True, False) -> t ++ ' ' : s -- add space if none + _ -> t ++ s + where + (spc, rest) = span isSpace s + + closingOrPunctuation :: String -> Bool + closingOrPunctuation [c] = c `elem` closerOrPunct + closingOrPunctuation _ = False + + closerOrPunct :: String + closerOrPunct = ")],;" parenth :: Doc -> Doc parenth ss = doc (showChar '(') . ss . doc (showChar ')') @@ -104,11 +123,10 @@ replicateS :: Int -> ShowS -> ShowS replicateS n f = concatS (replicate n f) -- | The printer class does the job. - class Print a where prt :: Int -> a -> Doc -instance {-# OVERLAPPABLE #-} Print a => Print [a] where +instance {-# OVERLAPPABLE #-} (Print a) => Print [a] where prt i = concatD . map (prt i) instance Print Char where @@ -139,6 +157,7 @@ instance Print Double where instance Print HM.Parser.Abs.Ident where prt _ (HM.Parser.Abs.Ident i) = doc $ showString i + instance Print HM.Parser.Abs.Pattern where prt i = \case HM.Parser.Abs.PatternVar id_ -> prPrec i 0 (concatD [prt 0 id_]) From 537aed7485011730bf3d86ce7f9fbaa19daa63c0 Mon Sep 17 00:00:00 2001 From: frog-da <84839431+frog-da@users.noreply.github.com> Date: Sun, 1 Sep 2024 14:30:10 +0300 Subject: [PATCH 4/8] Eval is done --- grammar/hindley-milner.cf | 2 +- src/HM/Eval.hs | 11 +++++++- src/HM/Parser/Doc.txt | 2 +- src/HM/Parser/Par.hs | 58 ++++++--------------------------------- src/HM/Parser/Par.y | 2 +- src/HM/Parser/Print.hs | 2 +- 6 files changed, 23 insertions(+), 54 deletions(-) diff --git a/grammar/hindley-milner.cf b/grammar/hindley-milner.cf index d14b653..7ba4204 100644 --- a/grammar/hindley-milner.cf +++ b/grammar/hindley-milner.cf @@ -11,7 +11,7 @@ EIsZero. Exp2 ::= "iszero" "(" Exp ")" ; ETyped. Exp ::= Exp1 ":" Type ; ELet. Exp1 ::= "let" Pattern "=" Exp1 "in" ScopedExp ; EAbs. Exp1 ::= "λ" Pattern ":" Type "." ScopedExp ; -EApp. Exp1 ::= Exp1 Exp1 ; +EApp. Exp1 ::= Exp1 Exp2 ; ScopedExp. ScopedExp ::= Exp1 ; diff --git a/src/HM/Eval.hs b/src/HM/Eval.hs index ca50494..61409de 100644 --- a/src/HM/Eval.hs +++ b/src/HM/Eval.hs @@ -52,4 +52,13 @@ eval scope (ETyped e _) = eval scope e eval scope (ELet e1 x e2) = do e1' <- eval scope e1 let subst = addSubst identitySubst x e1' - eval scope (substitute scope subst e2) \ No newline at end of file + eval scope (substitute scope subst e2) +eval _scope (EAbs type_ x e) = Right (EAbs type_ x e) +eval scope (EApp e1 e2) = do + e1' <- eval scope e1 + e2' <- eval scope e2 + case e1' of + EAbs _ x e -> do + let subst = addSubst identitySubst x e2' + eval scope (substitute scope subst e) + _ -> Left "Unsupported expression in application" diff --git a/src/HM/Parser/Doc.txt b/src/HM/Parser/Doc.txt index 9903e6a..e14ac1a 100644 --- a/src/HM/Parser/Doc.txt +++ b/src/HM/Parser/Doc.txt @@ -55,7 +55,7 @@ All other symbols are terminals. | //Exp1// | -> | ``if`` //Exp1// ``then`` //Exp1// ``else`` //Exp1// | | **|** | ``let`` //Pattern// ``=`` //Exp1// ``in`` //ScopedExp// | | **|** | ``λ`` //Pattern// ``:`` //Type// ``.`` //ScopedExp// - | | **|** | //Exp1// //Exp1// + | | **|** | //Exp1// //Exp2// | | **|** | //Exp2// | //Exp// | -> | //Exp1// ``:`` //Type// | | **|** | //Exp1// diff --git a/src/HM/Parser/Par.hs b/src/HM/Parser/Par.hs index 559fd8d..153ee5e 100644 --- a/src/HM/Parser/Par.hs +++ b/src/HM/Parser/Par.hs @@ -440,18 +440,14 @@ action_15 _ = happyReduce_23 action_16 (19) = happyShift action_18 action_16 (30) = happyShift action_19 -action_16 (31) = happyShift action_20 action_16 (33) = happyShift action_21 -action_16 (34) = happyShift action_22 action_16 (36) = happyShift action_23 -action_16 (37) = happyShift action_24 action_16 (38) = happyShift action_8 action_16 (39) = happyShift action_25 action_16 (10) = happyGoto action_12 action_16 (11) = happyGoto action_13 action_16 (13) = happyGoto action_14 -action_16 (14) = happyGoto action_15 -action_16 (15) = happyGoto action_35 +action_16 (14) = happyGoto action_35 action_16 _ = happyReduce_26 action_17 (40) = happyAccept @@ -512,18 +508,14 @@ action_25 _ = happyReduce_8 action_26 (19) = happyShift action_18 action_26 (25) = happyShift action_36 action_26 (30) = happyShift action_19 -action_26 (31) = happyShift action_20 action_26 (33) = happyShift action_21 -action_26 (34) = happyShift action_22 action_26 (36) = happyShift action_23 -action_26 (37) = happyShift action_24 action_26 (38) = happyShift action_8 action_26 (39) = happyShift action_25 action_26 (10) = happyGoto action_12 action_26 (11) = happyGoto action_13 action_26 (13) = happyGoto action_14 -action_26 (14) = happyGoto action_15 -action_26 (15) = happyGoto action_35 +action_26 (14) = happyGoto action_35 action_26 _ = happyReduce_25 action_27 (40) = happyAccept @@ -531,19 +523,15 @@ action_27 _ = happyFail (happyExpListPerState 27) action_28 (19) = happyShift action_18 action_28 (30) = happyShift action_19 -action_28 (31) = happyShift action_20 action_28 (33) = happyShift action_21 -action_28 (34) = happyShift action_22 action_28 (36) = happyShift action_23 -action_28 (37) = happyShift action_24 action_28 (38) = happyShift action_8 action_28 (39) = happyShift action_25 action_28 (40) = happyAccept action_28 (10) = happyGoto action_12 action_28 (11) = happyGoto action_13 action_28 (13) = happyGoto action_14 -action_28 (14) = happyGoto action_15 -action_28 (15) = happyGoto action_35 +action_28 (14) = happyGoto action_35 action_28 _ = happyFail (happyExpListPerState 28) action_29 (21) = happyShift action_33 @@ -579,20 +567,8 @@ action_34 (11) = happyGoto action_13 action_34 (13) = happyGoto action_50 action_34 _ = happyFail (happyExpListPerState 34) -action_35 (19) = happyShift action_18 -action_35 (30) = happyShift action_19 -action_35 (31) = happyShift action_20 -action_35 (33) = happyShift action_21 -action_35 (34) = happyShift action_22 -action_35 (36) = happyShift action_23 -action_35 (37) = happyShift action_24 -action_35 (38) = happyShift action_8 -action_35 (39) = happyShift action_25 -action_35 (10) = happyGoto action_12 -action_35 (11) = happyGoto action_13 -action_35 (13) = happyGoto action_14 -action_35 (14) = happyGoto action_15 -action_35 (15) = happyGoto action_35 +action_35 (21) = happyShift action_33 +action_35 (22) = happyShift action_34 action_35 _ = happyReduce_22 action_36 (27) = happyShift action_10 @@ -625,19 +601,15 @@ action_39 _ = happyFail (happyExpListPerState 39) action_40 (19) = happyShift action_18 action_40 (30) = happyShift action_19 -action_40 (31) = happyShift action_20 action_40 (33) = happyShift action_21 -action_40 (34) = happyShift action_22 action_40 (35) = happyShift action_45 action_40 (36) = happyShift action_23 -action_40 (37) = happyShift action_24 action_40 (38) = happyShift action_8 action_40 (39) = happyShift action_25 action_40 (10) = happyGoto action_12 action_40 (11) = happyGoto action_13 action_40 (13) = happyGoto action_14 -action_40 (14) = happyGoto action_15 -action_40 (15) = happyGoto action_35 +action_40 (14) = happyGoto action_35 action_40 _ = happyFail (happyExpListPerState 40) action_41 (20) = happyShift action_44 @@ -706,19 +678,15 @@ action_52 _ = happyFail (happyExpListPerState 52) action_53 (19) = happyShift action_18 action_53 (30) = happyShift action_19 -action_53 (31) = happyShift action_20 action_53 (32) = happyShift action_57 action_53 (33) = happyShift action_21 -action_53 (34) = happyShift action_22 action_53 (36) = happyShift action_23 -action_53 (37) = happyShift action_24 action_53 (38) = happyShift action_8 action_53 (39) = happyShift action_25 action_53 (10) = happyGoto action_12 action_53 (11) = happyGoto action_13 action_53 (13) = happyGoto action_14 -action_53 (14) = happyGoto action_15 -action_53 (15) = happyGoto action_35 +action_53 (14) = happyGoto action_35 action_53 _ = happyFail (happyExpListPerState 53) action_54 _ = happyReduce_17 @@ -726,18 +694,14 @@ action_54 _ = happyReduce_17 action_55 (19) = happyShift action_18 action_55 (29) = happyShift action_56 action_55 (30) = happyShift action_19 -action_55 (31) = happyShift action_20 action_55 (33) = happyShift action_21 -action_55 (34) = happyShift action_22 action_55 (36) = happyShift action_23 -action_55 (37) = happyShift action_24 action_55 (38) = happyShift action_8 action_55 (39) = happyShift action_25 action_55 (10) = happyGoto action_12 action_55 (11) = happyGoto action_13 action_55 (13) = happyGoto action_14 -action_55 (14) = happyGoto action_15 -action_55 (15) = happyGoto action_35 +action_55 (14) = happyGoto action_35 action_55 _ = happyFail (happyExpListPerState 55) action_56 (19) = happyShift action_18 @@ -796,18 +760,14 @@ action_60 _ = happyReduce_20 action_61 (19) = happyShift action_18 action_61 (30) = happyShift action_19 -action_61 (31) = happyShift action_20 action_61 (33) = happyShift action_21 -action_61 (34) = happyShift action_22 action_61 (36) = happyShift action_23 -action_61 (37) = happyShift action_24 action_61 (38) = happyShift action_8 action_61 (39) = happyShift action_25 action_61 (10) = happyGoto action_12 action_61 (11) = happyGoto action_13 action_61 (13) = happyGoto action_14 -action_61 (14) = happyGoto action_15 -action_61 (15) = happyGoto action_35 +action_61 (14) = happyGoto action_35 action_61 _ = happyReduce_19 happyReduce_7 = happySpecReduce_1 10 happyReduction_7 diff --git a/src/HM/Parser/Par.y b/src/HM/Parser/Par.y index 8746dd9..1db0f1d 100644 --- a/src/HM/Parser/Par.y +++ b/src/HM/Parser/Par.y @@ -88,7 +88,7 @@ Exp1 : 'if' Exp1 'then' Exp1 'else' Exp1 { HM.Parser.Abs.EIf $2 $4 $6 } | 'let' Pattern '=' Exp1 'in' ScopedExp { HM.Parser.Abs.ELet $2 $4 $6 } | 'λ' Pattern ':' Type '.' ScopedExp { HM.Parser.Abs.EAbs $2 $4 $6 } - | Exp1 Exp1 { HM.Parser.Abs.EApp $1 $2 } + | Exp1 Exp2 { HM.Parser.Abs.EApp $1 $2 } | Exp2 { $1 } Exp :: { HM.Parser.Abs.Exp } diff --git a/src/HM/Parser/Print.hs b/src/HM/Parser/Print.hs index 1bca676..5a70bc9 100644 --- a/src/HM/Parser/Print.hs +++ b/src/HM/Parser/Print.hs @@ -175,7 +175,7 @@ instance Print HM.Parser.Abs.Exp where HM.Parser.Abs.ETyped exp type_ -> prPrec i 0 (concatD [prt 1 exp, doc (showString ":"), prt 0 type_]) HM.Parser.Abs.ELet pattern_ exp scopedexp -> prPrec i 1 (concatD [doc (showString "let"), prt 0 pattern_, doc (showString "="), prt 1 exp, doc (showString "in"), prt 0 scopedexp]) HM.Parser.Abs.EAbs pattern_ type_ scopedexp -> prPrec i 1 (concatD [doc (showString "\955"), prt 0 pattern_, doc (showString ":"), prt 0 type_, doc (showString "."), prt 0 scopedexp]) - HM.Parser.Abs.EApp exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, prt 1 exp2]) + HM.Parser.Abs.EApp exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, prt 2 exp2]) instance Print HM.Parser.Abs.ScopedExp where prt i = \case From d287339ab13539dc5b463725f44ca4e5050e1d46 Mon Sep 17 00:00:00 2001 From: frog-da <84839431+frog-da@users.noreply.github.com> Date: Sun, 1 Sep 2024 14:54:35 +0300 Subject: [PATCH 5/8] Add tests --- test/files/ill-typed/7.lam | 1 + test/files/ill-typed/8.lam | 1 + test/files/ill-typed/9.lam | 1 + test/files/well-typed/7.lam | 1 + test/files/well-typed/8.lam | 1 + test/files/well-typed/9.lam | 1 + 6 files changed, 6 insertions(+) create mode 100644 test/files/ill-typed/7.lam create mode 100644 test/files/ill-typed/8.lam create mode 100644 test/files/ill-typed/9.lam create mode 100644 test/files/well-typed/7.lam create mode 100644 test/files/well-typed/8.lam create mode 100644 test/files/well-typed/9.lam diff --git a/test/files/ill-typed/7.lam b/test/files/ill-typed/7.lam new file mode 100644 index 0000000..f446180 --- /dev/null +++ b/test/files/ill-typed/7.lam @@ -0,0 +1 @@ +λx:Nat. let y = x + 1 in y : Nat -> Bool \ No newline at end of file diff --git a/test/files/ill-typed/8.lam b/test/files/ill-typed/8.lam new file mode 100644 index 0000000..c279aee --- /dev/null +++ b/test/files/ill-typed/8.lam @@ -0,0 +1 @@ +let f = λx:Nat. x + 1 in f true \ No newline at end of file diff --git a/test/files/ill-typed/9.lam b/test/files/ill-typed/9.lam new file mode 100644 index 0000000..3388fe3 --- /dev/null +++ b/test/files/ill-typed/9.lam @@ -0,0 +1 @@ +let f = if iszero (5) then (λx:Nat. x) else (λx:Bool. x + 1) in f 5 \ No newline at end of file diff --git a/test/files/well-typed/7.lam b/test/files/well-typed/7.lam new file mode 100644 index 0000000..34d456e --- /dev/null +++ b/test/files/well-typed/7.lam @@ -0,0 +1 @@ +(λx:Nat. if iszero (x) then 0 else x + 1) 5 \ No newline at end of file diff --git a/test/files/well-typed/8.lam b/test/files/well-typed/8.lam new file mode 100644 index 0000000..4bbb9f9 --- /dev/null +++ b/test/files/well-typed/8.lam @@ -0,0 +1 @@ +let f = λx:Nat. x + 1 in f 5 \ No newline at end of file diff --git a/test/files/well-typed/9.lam b/test/files/well-typed/9.lam new file mode 100644 index 0000000..7d03101 --- /dev/null +++ b/test/files/well-typed/9.lam @@ -0,0 +1 @@ +let f = if iszero (5) then (λx:Nat. x) else (λx:Nat. x + 1) in f 5 \ No newline at end of file From cc9c1fe7fde9ab27f49038d5995127f4093c323a Mon Sep 17 00:00:00 2001 From: frog-da <84839431+frog-da@users.noreply.github.com> Date: Sun, 1 Sep 2024 15:03:39 +0300 Subject: [PATCH 6/8] Update InterpretSpec.hs --- test/HM/InterpretSpec.hs | 60 ++++++++++++++-------------------------- 1 file changed, 21 insertions(+), 39 deletions(-) diff --git a/test/HM/InterpretSpec.hs b/test/HM/InterpretSpec.hs index 9f0f2c5..f79dcba 100644 --- a/test/HM/InterpretSpec.hs +++ b/test/HM/InterpretSpec.hs @@ -1,50 +1,32 @@ module HM.InterpretSpec where +import Test.Hspec import Control.Monad (forM_) -import HM.Interpret -import System.Directory -import System.FilePath -import Test.Hspec - -spec :: Spec -spec = parallel $ do - describe "well-typed expressions" $ do - paths <- runIO (testFilesInDir "./test/files/well-typed") - forM_ paths $ \path -> it path $ do - contents <- readFile path - interpret contents `shouldSatisfy` isSuccess - - describe "ill-typed expressions" $ do - paths <- runIO (testFilesInDir "./test/files/ill-typed") - forM_ paths $ \path -> it path $ do - contents <- readFile path - interpret contents `shouldSatisfy` isTypeError +import HM.Interpret isSuccess :: Result -> Bool -isSuccess Success {} = True +isSuccess Success{} = True isSuccess _ = False isTypeError :: Result -> Bool isTypeError (Failure TypecheckingError _) = True isTypeError _ = False -testFilesInDir :: FilePath -> IO [FilePath] -testFilesInDir dir = do - let isTestFile = \f -> return $ takeExtension f == ".lam" - dirWalk isTestFile dir - -dirWalk :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] -dirWalk filefunc top = do - isDirectory <- doesDirectoryExist top - if isDirectory - then do - -- Files preserving full path with `top` - files <- map (top ) <$> listDirectory top - paths <- mapM (dirWalk filefunc) files - return $ concat paths - else do - included <- filefunc top - return $ - if included - then [top] - else [] +wellTypedPaths :: [FilePath] +wellTypedPaths = ["well-typed/1.lam", "well-typed/2.lam", "well-typed/7.lam", "well-typed/8.lam", "well-typed/9.lam"] + +illTypedPaths :: [FilePath] +illTypedPaths = ["ill-typed/1.lam", "ill-typed/2.lam", "ill-typed/7.lam", "ill-typed/8.lam", "ill-typed/9.lam"] + +spec :: Spec +spec = do + + describe "well-typed expressions" $ do + forM_ wellTypedPaths $ \path -> it path $ do + contents <- readFile ("test/files/" ++ path) + interpret contents `shouldSatisfy` isSuccess + + describe "ill-typed expressions" $ do + forM_ illTypedPaths $ \path -> it path $ do + contents <- readFile ("test/files/" ++ path) + interpret contents `shouldSatisfy` isTypeError From 00365f0a2d8ba7808572274322aee5dfc26dba19 Mon Sep 17 00:00:00 2001 From: evermake Date: Tue, 3 Sep 2024 00:26:51 +0500 Subject: [PATCH 7/8] format and re-generate files --- src/HM/Parser/Abs.hs | 34 +- src/HM/Parser/Par.hs | 1272 +++++++++++++++++++--------------------- src/HM/Parser/Print.hs | 157 +++-- src/HM/Typecheck.hs | 2 +- 4 files changed, 693 insertions(+), 772 deletions(-) diff --git a/src/HM/Parser/Abs.hs b/src/HM/Parser/Abs.hs index dd85112..dcff1da 100644 --- a/src/HM/Parser/Abs.hs +++ b/src/HM/Parser/Abs.hs @@ -1,33 +1,36 @@ -- File generated by the BNF Converter (bnfc 2.9.5). + {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | The abstract syntax of language Parser. + module HM.Parser.Abs where -import qualified Data.Data as C (Data, Typeable) +import Prelude (Integer, String) +import qualified Prelude as C (Eq, Ord, Show, Read) import qualified Data.String + +import qualified Data.Data as C (Data, Typeable) import qualified GHC.Generics as C (Generic) -import Prelude (Integer, String) -import qualified Prelude as C (Eq, Ord, Read, Show) data Pattern = PatternVar Ident deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data Exp - = EVar Ident - | ETrue - | EFalse - | ENat Integer - | EAdd Exp Exp - | ESub Exp Exp - | EIf Exp Exp Exp - | EIsZero Exp - | ETyped Exp Type - | ELet Pattern Exp ScopedExp - | EAbs Pattern Type ScopedExp - | EApp Exp Exp + = EVar Ident + | ETrue + | EFalse + | ENat Integer + | EAdd Exp Exp + | ESub Exp Exp + | EIf Exp Exp Exp + | EIsZero Exp + | ETyped Exp Type + | ELet Pattern Exp ScopedExp + | EAbs Pattern Type ScopedExp + | EApp Exp Exp deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data ScopedExp = ScopedExp Exp @@ -38,3 +41,4 @@ data Type = TNat | TBool | TArrow Type Type newtype Ident = Ident String deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic, Data.String.IsString) + diff --git a/src/HM/Parser/Par.hs b/src/HM/Parser/Par.hs index 153ee5e..cc98246 100644 --- a/src/HM/Parser/Par.hs +++ b/src/HM/Parser/Par.hs @@ -1,39 +1,39 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} {-# OPTIONS_GHC -w #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} +{-# LANGUAGE PatternSynonyms #-} module HM.Parser.Par - ( happyError, - myLexer, - pPattern, - pExp3, - pExp2, - pExp1, - pExp, - pScopedExp, - pType, - ) -where - -import Control.Applicative (Applicative (..)) -import Control.Monad (ap) -import qualified Data.Array as Happy_Data_Array -import qualified Data.Bits as Bits + ( happyError + , myLexer + , pPattern + , pExp3 + , pExp2 + , pExp1 + , pExp + , pScopedExp + , pType + ) where + +import Prelude + import qualified HM.Parser.Abs import HM.Parser.Lex -import Prelude +import qualified Data.Array as Happy_Data_Array +import qualified Data.Bits as Bits +import Control.Applicative(Applicative(..)) +import Control.Monad (ap) -- parser produced by Happy Version 1.20.1.1 -data HappyAbsSyn - = HappyTerminal (Token) - | HappyErrorToken Prelude.Int - | HappyAbsSyn10 (HM.Parser.Abs.Ident) - | HappyAbsSyn11 (Integer) - | HappyAbsSyn12 (HM.Parser.Abs.Pattern) - | HappyAbsSyn13 (HM.Parser.Abs.Exp) - | HappyAbsSyn17 (HM.Parser.Abs.ScopedExp) - | HappyAbsSyn18 (HM.Parser.Abs.Type) +data HappyAbsSyn + = HappyTerminal (Token) + | HappyErrorToken Prelude.Int + | HappyAbsSyn10 (HM.Parser.Abs.Ident) + | HappyAbsSyn11 (Integer) + | HappyAbsSyn12 (HM.Parser.Abs.Pattern) + | HappyAbsSyn13 (HM.Parser.Abs.Exp) + | HappyAbsSyn17 (HM.Parser.Abs.ScopedExp) + | HappyAbsSyn18 (HM.Parser.Abs.Type) {- to allow type-synonyms as our monads (likely - with explicitly-specified bind and return) @@ -41,297 +41,130 @@ data HappyAbsSyn - /type M a = .../, then /(HappyReduction M)/ - is not allowed. But Happy is a - code-generator that can just substitute it. -type HappyReduction m = - Prelude.Int +type HappyReduction m = + Prelude.Int -> (Token) -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] - -> HappyStk HappyAbsSyn + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] + -> HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn -} action_0, - action_1, - action_2, - action_3, - action_4, - action_5, - action_6, - action_7, - action_8, - action_9, - action_10, - action_11, - action_12, - action_13, - action_14, - action_15, - action_16, - action_17, - action_18, - action_19, - action_20, - action_21, - action_22, - action_23, - action_24, - action_25, - action_26, - action_27, - action_28, - action_29, - action_30, - action_31, - action_32, - action_33, - action_34, - action_35, - action_36, - action_37, - action_38, - action_39, - action_40, - action_41, - action_42, - action_43, - action_44, - action_45, - action_46, - action_47, - action_48, - action_49, - action_50, - action_51, - action_52, - action_53, - action_54, - action_55, - action_56, - action_57, - action_58, - action_59, - action_60, - action_61 :: - () => - Prelude.Int -> - ( {-HappyReduction (Err) = -} - Prelude.Int -> - (Token) -> - HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) -> - [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] -> - HappyStk HappyAbsSyn -> - [(Token)] -> - (Err) HappyAbsSyn - ) + action_1, + action_2, + action_3, + action_4, + action_5, + action_6, + action_7, + action_8, + action_9, + action_10, + action_11, + action_12, + action_13, + action_14, + action_15, + action_16, + action_17, + action_18, + action_19, + action_20, + action_21, + action_22, + action_23, + action_24, + action_25, + action_26, + action_27, + action_28, + action_29, + action_30, + action_31, + action_32, + action_33, + action_34, + action_35, + action_36, + action_37, + action_38, + action_39, + action_40, + action_41, + action_42, + action_43, + action_44, + action_45, + action_46, + action_47, + action_48, + action_49, + action_50, + action_51, + action_52, + action_53, + action_54, + action_55, + action_56, + action_57, + action_58, + action_59, + action_60, + action_61 :: () => Prelude.Int -> ({-HappyReduction (Err) = -} + Prelude.Int + -> (Token) + -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> (Err) HappyAbsSyn) + happyReduce_7, - happyReduce_8, - happyReduce_9, - happyReduce_10, - happyReduce_11, - happyReduce_12, - happyReduce_13, - happyReduce_14, - happyReduce_15, - happyReduce_16, - happyReduce_17, - happyReduce_18, - happyReduce_19, - happyReduce_20, - happyReduce_21, - happyReduce_22, - happyReduce_23, - happyReduce_24, - happyReduce_25, - happyReduce_26, - happyReduce_27, - happyReduce_28, - happyReduce_29 :: - () => - ( {-HappyReduction (Err) = -} - Prelude.Int -> - (Token) -> - HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) -> - [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] -> - HappyStk HappyAbsSyn -> - [(Token)] -> - (Err) HappyAbsSyn - ) + happyReduce_8, + happyReduce_9, + happyReduce_10, + happyReduce_11, + happyReduce_12, + happyReduce_13, + happyReduce_14, + happyReduce_15, + happyReduce_16, + happyReduce_17, + happyReduce_18, + happyReduce_19, + happyReduce_20, + happyReduce_21, + happyReduce_22, + happyReduce_23, + happyReduce_24, + happyReduce_25, + happyReduce_26, + happyReduce_27, + happyReduce_28, + happyReduce_29 :: () => ({-HappyReduction (Err) = -} + Prelude.Int + -> (Token) + -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn) + -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Err) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> (Err) HappyAbsSyn) + happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int -happyExpList = - Happy_Data_Array.listArray - (0, 232) - ( [ 0, - 0, - 32, - 1024, - 26656, - 0, - 8196, - 105, - 1024, - 31584, - 0, - 24580, - 123, - 1024, - 31584, - 0, - 3072, - 0, - 0, - 8192, - 0, - 0, - 0, - 16384, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 12288, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 24580, - 123, - 0, - 0, - 0, - 24580, - 123, - 1024, - 0, - 0, - 0, - 32, - 0, - 0, - 0, - 0, - 32, - 0, - 0, - 0, - 24836, - 123, - 0, - 0, - 0, - 24580, - 123, - 12288, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 1024, - 26656, - 0, - 8196, - 104, - 0, - 0, - 0, - 3072, - 0, - 0, - 1, - 0, - 512, - 0, - 1024, - 31584, - 0, - 24580, - 127, - 2048, - 0, - 0, - 3072, - 0, - 0, - 0, - 0, - 0, - 0, - 1024, - 31584, - 0, - 8, - 0, - 1024, - 31584, - 0, - 3072, - 0, - 16384, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 192, - 0, - 1024, - 31712, - 0, - 0, - 0, - 1024, - 31600, - 0, - 24580, - 123, - 1024, - 31584, - 0, - 24580, - 123, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0 - ] - ) +happyExpList = Happy_Data_Array.listArray (0,193) ([0,0,32,1024,26656,0,8196,105,1024,31584,0,24580,123,1024,31584,0,3072,0,0,8192,0,0,0,16384,0,0,0,0,0,0,0,0,0,0,0,0,0,0,12288,0,0,0,0,0,0,0,24580,123,0,0,0,24580,123,1024,0,0,0,32,0,0,0,0,32,0,0,0,8452,105,0,0,0,8196,105,12288,0,0,0,0,0,0,0,0,0,1024,26656,0,8196,104,12288,0,0,3072,0,0,1,0,512,0,1024,31584,0,8196,109,2048,0,0,3072,0,0,0,0,0,0,1024,31584,0,8,0,1024,31584,0,3072,0,16384,0,0,0,0,0,0,0,192,0,1024,27040,0,0,0,1024,26928,0,24580,123,1024,31584,0,24580,123,0,0,0,0,0,0,0,0 + ]) {-# NOINLINE happyExpListPerState #-} happyExpListPerState st = - token_strs_expected - where - token_strs = ["error", "%dummy", "%start_pPattern", "%start_pExp3", "%start_pExp2", "%start_pExp1", "%start_pExp", "%start_pScopedExp", "%start_pType", "Ident", "Integer", "Pattern", "Exp3", "Exp2", "Exp1", "Exp", "ScopedExp", "Type", "'('", "')'", "'+'", "'-'", "'->'", "'.'", "':'", "'='", "'Bool'", "'Nat'", "'else'", "'false'", "'if'", "'in'", "'iszero'", "'let'", "'then'", "'true'", "'\955'", "L_Ident", "L_integ", "%eof"] - bit_start = st Prelude.* 40 - bit_end = (st Prelude.+ 1) Prelude.* 40 - read_bit = readArrayBit happyExpList - bits = Prelude.map read_bit [bit_start .. bit_end Prelude.- 1] - bits_indexed = Prelude.zip bits [0 .. 39] - token_strs_expected = Prelude.concatMap f bits_indexed - f (Prelude.False, _) = [] - f (Prelude.True, nr) = [token_strs Prelude.!! nr] + token_strs_expected + where token_strs = ["error","%dummy","%start_pPattern","%start_pExp3","%start_pExp2","%start_pExp1","%start_pExp","%start_pScopedExp","%start_pType","Ident","Integer","Pattern","Exp3","Exp2","Exp1","Exp","ScopedExp","Type","'('","')'","'+'","'-'","'->'","'.'","':'","'='","'Bool'","'Nat'","'else'","'false'","'if'","'in'","'iszero'","'let'","'then'","'true'","'\955'","L_Ident","L_integ","%eof"] + bit_start = st Prelude.* 40 + bit_end = (st Prelude.+ 1) Prelude.* 40 + read_bit = readArrayBit happyExpList + bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] + bits_indexed = Prelude.zip bits [0..39] + token_strs_expected = Prelude.concatMap f bits_indexed + f (Prelude.False, _) = [] + f (Prelude.True, nr) = [token_strs Prelude.!! nr] action_0 (38) = happyShift action_8 action_0 (10) = happyGoto action_31 @@ -770,329 +603,356 @@ action_61 (13) = happyGoto action_14 action_61 (14) = happyGoto action_35 action_61 _ = happyReduce_19 -happyReduce_7 = happySpecReduce_1 10 happyReduction_7 - -happyReduction_7 (HappyTerminal (PT _ (TV happy_var_1))) = - HappyAbsSyn10 - ( HM.Parser.Abs.Ident happy_var_1 - ) -happyReduction_7 _ = notHappyAtAll - -happyReduce_8 = happySpecReduce_1 11 happyReduction_8 - -happyReduction_8 (HappyTerminal (PT _ (TI happy_var_1))) = - HappyAbsSyn11 - ( (read happy_var_1) :: Integer - ) -happyReduction_8 _ = notHappyAtAll - -happyReduce_9 = happySpecReduce_1 12 happyReduction_9 - -happyReduction_9 (HappyAbsSyn10 happy_var_1) = - HappyAbsSyn12 - ( HM.Parser.Abs.PatternVar happy_var_1 - ) -happyReduction_9 _ = notHappyAtAll - -happyReduce_10 = happySpecReduce_1 13 happyReduction_10 - -happyReduction_10 (HappyAbsSyn10 happy_var_1) = - HappyAbsSyn13 - ( HM.Parser.Abs.EVar happy_var_1 - ) -happyReduction_10 _ = notHappyAtAll - -happyReduce_11 = happySpecReduce_1 13 happyReduction_11 - -happyReduction_11 _ = - HappyAbsSyn13 - ( HM.Parser.Abs.ETrue - ) - -happyReduce_12 = happySpecReduce_1 13 happyReduction_12 - -happyReduction_12 _ = - HappyAbsSyn13 - ( HM.Parser.Abs.EFalse - ) - -happyReduce_13 = happySpecReduce_1 13 happyReduction_13 - -happyReduction_13 (HappyAbsSyn11 happy_var_1) = - HappyAbsSyn13 - ( HM.Parser.Abs.ENat happy_var_1 - ) -happyReduction_13 _ = notHappyAtAll - -happyReduce_14 = happySpecReduce_3 13 happyReduction_14 - -happyReduction_14 - _ - (HappyAbsSyn13 happy_var_2) - _ = - HappyAbsSyn13 - ( happy_var_2 - ) -happyReduction_14 _ _ _ = notHappyAtAll - -happyReduce_15 = happySpecReduce_3 14 happyReduction_15 - -happyReduction_15 - (HappyAbsSyn13 happy_var_3) - _ - (HappyAbsSyn13 happy_var_1) = - HappyAbsSyn13 - ( HM.Parser.Abs.EAdd happy_var_1 happy_var_3 - ) -happyReduction_15 _ _ _ = notHappyAtAll - -happyReduce_16 = happySpecReduce_3 14 happyReduction_16 - -happyReduction_16 - (HappyAbsSyn13 happy_var_3) - _ - (HappyAbsSyn13 happy_var_1) = - HappyAbsSyn13 - ( HM.Parser.Abs.ESub happy_var_1 happy_var_3 - ) -happyReduction_16 _ _ _ = notHappyAtAll +happyReduce_7 = happySpecReduce_1 10 happyReduction_7 +happyReduction_7 (HappyTerminal (PT _ (TV happy_var_1))) + = HappyAbsSyn10 + (HM.Parser.Abs.Ident happy_var_1 + ) +happyReduction_7 _ = notHappyAtAll + +happyReduce_8 = happySpecReduce_1 11 happyReduction_8 +happyReduction_8 (HappyTerminal (PT _ (TI happy_var_1))) + = HappyAbsSyn11 + ((read happy_var_1) :: Integer + ) +happyReduction_8 _ = notHappyAtAll + +happyReduce_9 = happySpecReduce_1 12 happyReduction_9 +happyReduction_9 (HappyAbsSyn10 happy_var_1) + = HappyAbsSyn12 + (HM.Parser.Abs.PatternVar happy_var_1 + ) +happyReduction_9 _ = notHappyAtAll + +happyReduce_10 = happySpecReduce_1 13 happyReduction_10 +happyReduction_10 (HappyAbsSyn10 happy_var_1) + = HappyAbsSyn13 + (HM.Parser.Abs.EVar happy_var_1 + ) +happyReduction_10 _ = notHappyAtAll + +happyReduce_11 = happySpecReduce_1 13 happyReduction_11 +happyReduction_11 _ + = HappyAbsSyn13 + (HM.Parser.Abs.ETrue + ) + +happyReduce_12 = happySpecReduce_1 13 happyReduction_12 +happyReduction_12 _ + = HappyAbsSyn13 + (HM.Parser.Abs.EFalse + ) + +happyReduce_13 = happySpecReduce_1 13 happyReduction_13 +happyReduction_13 (HappyAbsSyn11 happy_var_1) + = HappyAbsSyn13 + (HM.Parser.Abs.ENat happy_var_1 + ) +happyReduction_13 _ = notHappyAtAll + +happyReduce_14 = happySpecReduce_3 13 happyReduction_14 +happyReduction_14 _ + (HappyAbsSyn13 happy_var_2) + _ + = HappyAbsSyn13 + (happy_var_2 + ) +happyReduction_14 _ _ _ = notHappyAtAll + +happyReduce_15 = happySpecReduce_3 14 happyReduction_15 +happyReduction_15 (HappyAbsSyn13 happy_var_3) + _ + (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (HM.Parser.Abs.EAdd happy_var_1 happy_var_3 + ) +happyReduction_15 _ _ _ = notHappyAtAll + +happyReduce_16 = happySpecReduce_3 14 happyReduction_16 +happyReduction_16 (HappyAbsSyn13 happy_var_3) + _ + (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (HM.Parser.Abs.ESub happy_var_1 happy_var_3 + ) +happyReduction_16 _ _ _ = notHappyAtAll happyReduce_17 = happyReduce 4 14 happyReduction_17 - -happyReduction_17 - ( _ - `HappyStk` (HappyAbsSyn13 happy_var_3) - `HappyStk` _ - `HappyStk` _ - `HappyStk` happyRest - ) = - HappyAbsSyn13 - ( HM.Parser.Abs.EIsZero happy_var_3 - ) - `HappyStk` happyRest - -happyReduce_18 = happySpecReduce_1 14 happyReduction_18 - -happyReduction_18 (HappyAbsSyn13 happy_var_1) = - HappyAbsSyn13 - ( happy_var_1 - ) -happyReduction_18 _ = notHappyAtAll +happyReduction_17 (_ `HappyStk` + (HappyAbsSyn13 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (HM.Parser.Abs.EIsZero happy_var_3 + ) `HappyStk` happyRest + +happyReduce_18 = happySpecReduce_1 14 happyReduction_18 +happyReduction_18 (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (happy_var_1 + ) +happyReduction_18 _ = notHappyAtAll happyReduce_19 = happyReduce 6 15 happyReduction_19 - -happyReduction_19 - ( (HappyAbsSyn13 happy_var_6) - `HappyStk` _ - `HappyStk` (HappyAbsSyn13 happy_var_4) - `HappyStk` _ - `HappyStk` (HappyAbsSyn13 happy_var_2) - `HappyStk` _ - `HappyStk` happyRest - ) = - HappyAbsSyn13 - ( HM.Parser.Abs.EIf happy_var_2 happy_var_4 happy_var_6 - ) - `HappyStk` happyRest +happyReduction_19 ((HappyAbsSyn13 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (HM.Parser.Abs.EIf happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest happyReduce_20 = happyReduce 6 15 happyReduction_20 - -happyReduction_20 - ( (HappyAbsSyn17 happy_var_6) - `HappyStk` _ - `HappyStk` (HappyAbsSyn13 happy_var_4) - `HappyStk` _ - `HappyStk` (HappyAbsSyn12 happy_var_2) - `HappyStk` _ - `HappyStk` happyRest - ) = - HappyAbsSyn13 - ( HM.Parser.Abs.ELet happy_var_2 happy_var_4 happy_var_6 - ) - `HappyStk` happyRest +happyReduction_20 ((HappyAbsSyn17 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn12 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (HM.Parser.Abs.ELet happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest happyReduce_21 = happyReduce 6 15 happyReduction_21 - -happyReduction_21 - ( (HappyAbsSyn17 happy_var_6) - `HappyStk` _ - `HappyStk` (HappyAbsSyn18 happy_var_4) - `HappyStk` _ - `HappyStk` (HappyAbsSyn12 happy_var_2) - `HappyStk` _ - `HappyStk` happyRest - ) = - HappyAbsSyn13 - ( HM.Parser.Abs.EAbs happy_var_2 happy_var_4 happy_var_6 - ) - `HappyStk` happyRest - -happyReduce_22 = happySpecReduce_2 15 happyReduction_22 - -happyReduction_22 - (HappyAbsSyn13 happy_var_2) - (HappyAbsSyn13 happy_var_1) = - HappyAbsSyn13 - ( HM.Parser.Abs.EApp happy_var_1 happy_var_2 - ) -happyReduction_22 _ _ = notHappyAtAll - -happyReduce_23 = happySpecReduce_1 15 happyReduction_23 - -happyReduction_23 (HappyAbsSyn13 happy_var_1) = - HappyAbsSyn13 - ( happy_var_1 - ) -happyReduction_23 _ = notHappyAtAll - -happyReduce_24 = happySpecReduce_3 16 happyReduction_24 - -happyReduction_24 - (HappyAbsSyn18 happy_var_3) - _ - (HappyAbsSyn13 happy_var_1) = - HappyAbsSyn13 - ( HM.Parser.Abs.ETyped happy_var_1 happy_var_3 - ) -happyReduction_24 _ _ _ = notHappyAtAll - -happyReduce_25 = happySpecReduce_1 16 happyReduction_25 - -happyReduction_25 (HappyAbsSyn13 happy_var_1) = - HappyAbsSyn13 - ( happy_var_1 - ) -happyReduction_25 _ = notHappyAtAll - -happyReduce_26 = happySpecReduce_1 17 happyReduction_26 - -happyReduction_26 (HappyAbsSyn13 happy_var_1) = - HappyAbsSyn17 - ( HM.Parser.Abs.ScopedExp happy_var_1 - ) -happyReduction_26 _ = notHappyAtAll - -happyReduce_27 = happySpecReduce_1 18 happyReduction_27 - -happyReduction_27 _ = - HappyAbsSyn18 - ( HM.Parser.Abs.TNat - ) - -happyReduce_28 = happySpecReduce_1 18 happyReduction_28 - -happyReduction_28 _ = - HappyAbsSyn18 - ( HM.Parser.Abs.TBool - ) - -happyReduce_29 = happySpecReduce_3 18 happyReduction_29 - -happyReduction_29 - (HappyAbsSyn18 happy_var_3) - _ - (HappyAbsSyn18 happy_var_1) = - HappyAbsSyn18 - ( HM.Parser.Abs.TArrow happy_var_1 happy_var_3 - ) -happyReduction_29 _ _ _ = notHappyAtAll +happyReduction_21 ((HappyAbsSyn17 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn18 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn12 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (HM.Parser.Abs.EAbs happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest + +happyReduce_22 = happySpecReduce_2 15 happyReduction_22 +happyReduction_22 (HappyAbsSyn13 happy_var_2) + (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (HM.Parser.Abs.EApp happy_var_1 happy_var_2 + ) +happyReduction_22 _ _ = notHappyAtAll + +happyReduce_23 = happySpecReduce_1 15 happyReduction_23 +happyReduction_23 (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (happy_var_1 + ) +happyReduction_23 _ = notHappyAtAll + +happyReduce_24 = happySpecReduce_3 16 happyReduction_24 +happyReduction_24 (HappyAbsSyn18 happy_var_3) + _ + (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (HM.Parser.Abs.ETyped happy_var_1 happy_var_3 + ) +happyReduction_24 _ _ _ = notHappyAtAll + +happyReduce_25 = happySpecReduce_1 16 happyReduction_25 +happyReduction_25 (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn13 + (happy_var_1 + ) +happyReduction_25 _ = notHappyAtAll + +happyReduce_26 = happySpecReduce_1 17 happyReduction_26 +happyReduction_26 (HappyAbsSyn13 happy_var_1) + = HappyAbsSyn17 + (HM.Parser.Abs.ScopedExp happy_var_1 + ) +happyReduction_26 _ = notHappyAtAll + +happyReduce_27 = happySpecReduce_1 18 happyReduction_27 +happyReduction_27 _ + = HappyAbsSyn18 + (HM.Parser.Abs.TNat + ) + +happyReduce_28 = happySpecReduce_1 18 happyReduction_28 +happyReduction_28 _ + = HappyAbsSyn18 + (HM.Parser.Abs.TBool + ) + +happyReduce_29 = happySpecReduce_3 18 happyReduction_29 +happyReduction_29 (HappyAbsSyn18 happy_var_3) + _ + (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (HM.Parser.Abs.TArrow happy_var_1 happy_var_3 + ) +happyReduction_29 _ _ _ = notHappyAtAll happyNewToken action sts stk [] = - action 40 40 notHappyAtAll (HappyState action) sts stk [] -happyNewToken action sts stk (tk : tks) = - let cont i = action i i tk (HappyState action) sts stk tks - in case tk of - PT _ (TS _ 1) -> cont 19 - PT _ (TS _ 2) -> cont 20 - PT _ (TS _ 3) -> cont 21 - PT _ (TS _ 4) -> cont 22 - PT _ (TS _ 5) -> cont 23 - PT _ (TS _ 6) -> cont 24 - PT _ (TS _ 7) -> cont 25 - PT _ (TS _ 8) -> cont 26 - PT _ (TS _ 9) -> cont 27 - PT _ (TS _ 10) -> cont 28 - PT _ (TS _ 11) -> cont 29 - PT _ (TS _ 12) -> cont 30 - PT _ (TS _ 13) -> cont 31 - PT _ (TS _ 14) -> cont 32 - PT _ (TS _ 15) -> cont 33 - PT _ (TS _ 16) -> cont 34 - PT _ (TS _ 17) -> cont 35 - PT _ (TS _ 18) -> cont 36 - PT _ (TS _ 19) -> cont 37 - PT _ (TV happy_dollar_dollar) -> cont 38 - PT _ (TI happy_dollar_dollar) -> cont 39 - _ -> happyError' ((tk : tks), []) + action 40 40 notHappyAtAll (HappyState action) sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = action i i tk (HappyState action) sts stk tks in + case tk of { + PT _ (TS _ 1) -> cont 19; + PT _ (TS _ 2) -> cont 20; + PT _ (TS _ 3) -> cont 21; + PT _ (TS _ 4) -> cont 22; + PT _ (TS _ 5) -> cont 23; + PT _ (TS _ 6) -> cont 24; + PT _ (TS _ 7) -> cont 25; + PT _ (TS _ 8) -> cont 26; + PT _ (TS _ 9) -> cont 27; + PT _ (TS _ 10) -> cont 28; + PT _ (TS _ 11) -> cont 29; + PT _ (TS _ 12) -> cont 30; + PT _ (TS _ 13) -> cont 31; + PT _ (TS _ 14) -> cont 32; + PT _ (TS _ 15) -> cont 33; + PT _ (TS _ 16) -> cont 34; + PT _ (TS _ 17) -> cont 35; + PT _ (TS _ 18) -> cont 36; + PT _ (TS _ 19) -> cont 37; + PT _ (TV happy_dollar_dollar) -> cont 38; + PT _ (TI happy_dollar_dollar) -> cont 39; + _ -> happyError' ((tk:tks), []) + } happyError_ explist 40 tk tks = happyError' (tks, explist) -happyError_ explist _ tk tks = happyError' ((tk : tks), explist) +happyError_ explist _ tk tks = happyError' ((tk:tks), explist) happyThen :: () => Err a -> (a -> Err b) -> Err b happyThen = ((>>=)) - happyReturn :: () => a -> Err a happyReturn = (return) - happyThen1 m k tks = ((>>=)) m (\a -> k a tks) - happyReturn1 :: () => a -> b -> Err a happyReturn1 = \a tks -> (return) a - happyError' :: () => ([(Token)], [Prelude.String]) -> Err a happyError' = (\(tokens, _) -> happyError tokens) +pPattern tks = happySomeParser where + happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn12 z -> happyReturn z; _other -> notHappyAtAll }) -pPattern tks = happySomeParser - where - happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of HappyAbsSyn12 z -> happyReturn z; _other -> notHappyAtAll) +pExp3 tks = happySomeParser where + happySomeParser = happyThen (happyParse action_1 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) -pExp3 tks = happySomeParser - where - happySomeParser = happyThen (happyParse action_1 tks) (\x -> case x of HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll) +pExp2 tks = happySomeParser where + happySomeParser = happyThen (happyParse action_2 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) -pExp2 tks = happySomeParser - where - happySomeParser = happyThen (happyParse action_2 tks) (\x -> case x of HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll) +pExp1 tks = happySomeParser where + happySomeParser = happyThen (happyParse action_3 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) -pExp1 tks = happySomeParser - where - happySomeParser = happyThen (happyParse action_3 tks) (\x -> case x of HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll) +pExp tks = happySomeParser where + happySomeParser = happyThen (happyParse action_4 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) -pExp tks = happySomeParser - where - happySomeParser = happyThen (happyParse action_4 tks) (\x -> case x of HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll) +pScopedExp tks = happySomeParser where + happySomeParser = happyThen (happyParse action_5 tks) (\x -> case x of {HappyAbsSyn17 z -> happyReturn z; _other -> notHappyAtAll }) -pScopedExp tks = happySomeParser - where - happySomeParser = happyThen (happyParse action_5 tks) (\x -> case x of HappyAbsSyn17 z -> happyReturn z; _other -> notHappyAtAll) - -pType tks = happySomeParser - where - happySomeParser = happyThen (happyParse action_6 tks) (\x -> case x of HappyAbsSyn18 z -> happyReturn z; _other -> notHappyAtAll) +pType tks = happySomeParser where + happySomeParser = happyThen (happyParse action_6 tks) (\x -> case x of {HappyAbsSyn18 z -> happyReturn z; _other -> notHappyAtAll }) happySeq = happyDontSeq + type Err = Either String happyError :: [Token] -> Err a -happyError ts = - Left $ - "syntax error at " - ++ tokenPos ts - ++ case ts of - [] -> [] - [Err _] -> " due to lexer error" - t : _ -> " before `" ++ (prToken t) ++ "'" +happyError ts = Left $ + "syntax error at " ++ tokenPos ts ++ + case ts of + [] -> [] + [Err _] -> " due to lexer error" + t:_ -> " before `" ++ (prToken t) ++ "'" myLexer :: String -> [Token] myLexer = tokens {-# LINE 1 "templates/GenericTemplate.hs" #-} -- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + data Happy_IntList = HappyCons Prelude.Int Happy_IntList -infixr 9 `HappyStk` + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) ----------------------------------------------------------------------------- @@ -1107,121 +967,191 @@ happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll -- parse (a %partial parser). We must ignore the saved token on the top of -- the stack in this case. happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyReturn1 ans) + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyReturn1 ans) ----------------------------------------------------------------------------- -- Arrays only: do the next action + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + indexShortOffAddr arr off = arr Happy_Data_Array.! off + {-# INLINE happyLt #-} happyLt x y = (x Prelude.< y) + + + + + readArrayBit arr bit = - Bits.testBit (indexShortOffAddr arr (bit `Prelude.div` 16)) (bit `Prelude.mod` 16) + Bits.testBit (indexShortOffAddr arr (bit `Prelude.div` 16)) (bit `Prelude.mod` 16) + + + + + ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -newtype HappyState b c - = HappyState - ( Prelude.Int -> -- token number - Prelude.Int -> -- token number (yes, again) - b -> -- token semantic value - HappyState b c -> -- current state - [HappyState b c] -> -- state stack - c - ) + + +newtype HappyState b c = HappyState + (Prelude.Int -> -- token number + Prelude.Int -> -- token number (yes, again) + b -> -- token semantic value + HappyState b c -> -- current state + [HappyState b c] -> -- state stack + c) + + ----------------------------------------------------------------------------- -- Shifting a token happyShift new_state (1) tk st sts stk@(x `HappyStk` _) = - let i = (case x of HappyErrorToken (i) -> i) - in -- trace "shifting the error token" $ - new_state i i tk (HappyState (new_state)) ((st) : (sts)) (stk) + let i = (case x of { HappyErrorToken (i) -> i }) in +-- trace "shifting the error token" $ + new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk) + happyShift new_state i tk st sts stk = - happyNewToken new_state ((st) : (sts)) ((HappyTerminal (tk)) `HappyStk` stk) + happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk) -- happyReduce is specialised for the common cases. -happySpecReduce_0 i fn (1) tk st sts stk = - happyFail [] (1) tk st sts stk -happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk = - action nt j tk st ((st) : (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn (1) tk st sts stk = - happyFail [] (1) tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))) : (_))) (v1 `HappyStk` stk') = - let r = fn v1 - in happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn (1) tk st sts stk = - happyFail [] (1) tk st sts stk -happySpecReduce_2 nt fn j tk _ ((_) : (sts@(((st@(HappyState (action))) : (_))))) (v1 `HappyStk` v2 `HappyStk` stk') = - let r = fn v1 v2 - in happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn (1) tk st sts stk = - happyFail [] (1) tk st sts stk -happySpecReduce_3 nt fn j tk _ ((_) : (((_) : (sts@(((st@(HappyState (action))) : (_))))))) (v1 `HappyStk` v2 `HappyStk` v3 `HappyStk` stk') = - let r = fn v1 v2 v3 - in happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn (1) tk st sts stk = - happyFail [] (1) tk st sts stk -happyReduce k nt fn j tk st sts stk = - case happyDrop (k Prelude.- ((1) :: Prelude.Int)) sts of - sts1@(((st1@(HappyState (action))) : (_))) -> - let r = fn stk -- it doesn't hurt to always seq here... - in happyDoSeq r (action nt j tk st1 sts1 r) - -happyMonadReduce k nt fn (1) tk st sts stk = - happyFail [] (1) tk st sts stk +happySpecReduce_0 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk + = action nt j tk st ((st):(sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Prelude.- ((1) :: Prelude.Int)) sts of + sts1@(((st1@(HappyState (action))):(_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (action nt j tk st1 sts1 r) + +happyMonadReduce k nt fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k ((st) : (sts)) of - sts1@(((st1@(HappyState (action))) : (_))) -> - let drop_stk = happyDropStk k stk - in happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) + case happyDrop k ((st):(sts)) of + sts1@(((st1@(HappyState (action))):(_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) -happyMonad2Reduce k nt fn (1) tk st sts stk = - happyFail [] (1) tk st sts stk +happyMonad2Reduce k nt fn (1) tk st sts stk + = happyFail [] (1) tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k ((st) : (sts)) of - sts1@(((st1@(HappyState (action))) : (_))) -> - let drop_stk = happyDropStk k stk + case happyDrop k ((st):(sts)) of + sts1@(((st1@(HappyState (action))):(_))) -> + let drop_stk = happyDropStk k stk - _ = nt :: Prelude.Int - new_state = action - in happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + + + + + _ = nt :: Prelude.Int + new_state = action + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) happyDrop (0) l = l -happyDrop n ((_) : (t)) = happyDrop (n Prelude.- ((1) :: Prelude.Int)) t +happyDrop n ((_):(t)) = happyDrop (n Prelude.- ((1) :: Prelude.Int)) t happyDropStk (0) l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Prelude.- ((1) :: Prelude.Int)) xs +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Prelude.- ((1)::Prelude.Int)) xs ----------------------------------------------------------------------------- -- Moving to a new state after a reduction + + + + + + + + happyGoto action j tk st = action j j tk (HappyState action) + ----------------------------------------------------------------------------- -- Error recovery (ERROR_TOK is the error token) -- parse error if we are in recovery and we fail again happyFail explist (1) tk old_st _ stk@(x `HappyStk` _) = - let i = (case x of HappyErrorToken (i) -> i) - in -- trace "failing" $ - happyError_ explist i tk + let i = (case x of { HappyErrorToken (i) -> i }) in +-- trace "failing" $ + happyError_ explist i tk + {- We don't need state discarding for our restricted implementation of "error". In fact, it can cause some bogus parses, so I've disabled it for now --SDM -- discard a state -happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) +happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) (saved_tok `HappyStk` _ `HappyStk` stk) = -- trace ("discarding state, depth " ++ show (length stk)) $ DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk)) @@ -1230,8 +1160,8 @@ happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) -- Enter error recovery: generate an error token, -- save the old token and carry on. happyFail explist i tk (HappyState (action)) sts stk = - -- trace "entering error recovery" $ - action (1) (1) tk (HappyState (action)) sts ((HappyErrorToken (i)) `HappyStk` stk) +-- trace "entering error recovery" $ + action (1) (1) tk (HappyState (action)) sts ((HappyErrorToken (i)) `HappyStk` stk) -- Internal happy errors: @@ -1241,14 +1171,20 @@ notHappyAtAll = Prelude.error "Internal Happy error\n" ----------------------------------------------------------------------------- -- Hack to get the typechecker to accept our action functions + + + + + + ----------------------------------------------------------------------------- --- Seq-ing. If the --strict flag is given, then Happy emits +-- Seq-ing. If the --strict flag is given, then Happy emits -- happySeq = happyDoSeq -- otherwise it emits -- happySeq = happyDontSeq happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `Prelude.seq` b +happyDoSeq a b = a `Prelude.seq` b happyDontSeq a b = b ----------------------------------------------------------------------------- @@ -1256,22 +1192,22 @@ happyDontSeq a b = b -- of deciding to inline happyGoto everywhere, which increases the size of -- the generated parser quite a bit. -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} {-# NOINLINE happyFail #-} -- end of Happy Template. diff --git a/src/HM/Parser/Print.hs b/src/HM/Parser/Print.hs index 5a70bc9..f1d2846 100644 --- a/src/HM/Parser/Print.hs +++ b/src/HM/Parser/Print.hs @@ -1,4 +1,5 @@ -- File generated by the BNF Converter (bnfc 2.9.5). + {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -7,40 +8,23 @@ #endif -- | Pretty-printer for HM. + module HM.Parser.Print where -import Data.Char (Char, isSpace) -import qualified HM.Parser.Abs import Prelude - ( Bool (..), - Double, - Int, - Integer, - ShowS, - String, - all, - elem, - foldr, - id, - map, - null, - replicate, - showChar, - showString, - shows, - span, - ($), - (*), - (+), - (++), - (-), - (.), - (<), - (==), + ( ($), (.) + , Bool(..), (==), (<) + , Int, Integer, Double, (+), (-), (*) + , String, (++) + , ShowS, showChar, showString + , all, elem, foldr, id, map, null, replicate, shows, span ) +import Data.Char ( Char, isSpace ) +import qualified HM.Parser.Abs -- | The top-level printing method. -printTree :: (Print a) => a -> String + +printTree :: Print a => a -> String printTree = render . prt 0 type Doc = [ShowS] -> [ShowS] @@ -51,64 +35,61 @@ doc = (:) render :: Doc -> String render d = rend 0 False (map ($ "") $ d []) "" where - rend :: - Int -> - -- \^ Indentation level. - Bool -> - -- \^ Pending indentation to be output before next character? - [String] -> - ShowS - rend i p = \case - "[" : ts -> char '[' . rend i False ts - "(" : ts -> char '(' . rend i False ts - "{" : ts -> onNewLine i p . showChar '{' . new (i + 1) ts - "}" : ";" : ts -> onNewLine (i - 1) p . showString "};" . new (i - 1) ts - "}" : ts -> onNewLine (i - 1) p . showChar '}' . new (i - 1) ts - [";"] -> char ';' - ";" : ts -> char ';' . new i ts - t : ts@(s : _) - | closingOrPunctuation s -> - pending . showString t . rend i False ts - t : ts -> pending . space t . rend i False ts - [] -> id - where - -- Output character after pending indentation. - char :: Char -> ShowS - char c = pending . showChar c - - -- Output pending indentation. - pending :: ShowS - pending = if p then indent i else id - - -- Indentation (spaces) for given indentation level. - indent :: Int -> ShowS - indent i = replicateS (2 * i) (showChar ' ') - - -- Continue rendering in new line with new indentation. - new :: Int -> [String] -> ShowS - new j ts = showChar '\n' . rend j True ts - - -- Make sure we are on a fresh line. - onNewLine :: Int -> Bool -> ShowS - onNewLine i p = (if p then id else showChar '\n') . indent i - - -- Separate given string from following text by a space (if needed). - space :: String -> ShowS - space t s = - case (all isSpace t, null spc, null rest) of - (True, _, True) -> [] -- remove trailing space - (False, _, True) -> t -- remove trailing space - (False, True, False) -> t ++ ' ' : s -- add space if none - _ -> t ++ s - where - (spc, rest) = span isSpace s - - closingOrPunctuation :: String -> Bool - closingOrPunctuation [c] = c `elem` closerOrPunct - closingOrPunctuation _ = False - - closerOrPunct :: String - closerOrPunct = ")],;" + rend + :: Int -- ^ Indentation level. + -> Bool -- ^ Pending indentation to be output before next character? + -> [String] + -> ShowS + rend i p = \case + "[" :ts -> char '[' . rend i False ts + "(" :ts -> char '(' . rend i False ts + "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts + "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts + "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts + [";"] -> char ';' + ";" :ts -> char ';' . new i ts + t : ts@(s:_) | closingOrPunctuation s + -> pending . showString t . rend i False ts + t :ts -> pending . space t . rend i False ts + [] -> id + where + -- Output character after pending indentation. + char :: Char -> ShowS + char c = pending . showChar c + + -- Output pending indentation. + pending :: ShowS + pending = if p then indent i else id + + -- Indentation (spaces) for given indentation level. + indent :: Int -> ShowS + indent i = replicateS (2*i) (showChar ' ') + + -- Continue rendering in new line with new indentation. + new :: Int -> [String] -> ShowS + new j ts = showChar '\n' . rend j True ts + + -- Make sure we are on a fresh line. + onNewLine :: Int -> Bool -> ShowS + onNewLine i p = (if p then id else showChar '\n') . indent i + + -- Separate given string from following text by a space (if needed). + space :: String -> ShowS + space t s = + case (all isSpace t, null spc, null rest) of + (True , _ , True ) -> [] -- remove trailing space + (False, _ , True ) -> t -- remove trailing space + (False, True, False) -> t ++ ' ' : s -- add space if none + _ -> t ++ s + where + (spc, rest) = span isSpace s + + closingOrPunctuation :: String -> Bool + closingOrPunctuation [c] = c `elem` closerOrPunct + closingOrPunctuation _ = False + + closerOrPunct :: String + closerOrPunct = ")],;" parenth :: Doc -> Doc parenth ss = doc (showChar '(') . ss . doc (showChar ')') @@ -123,10 +104,11 @@ replicateS :: Int -> ShowS -> ShowS replicateS n f = concatS (replicate n f) -- | The printer class does the job. + class Print a where prt :: Int -> a -> Doc -instance {-# OVERLAPPABLE #-} (Print a) => Print [a] where +instance {-# OVERLAPPABLE #-} Print a => Print [a] where prt i = concatD . map (prt i) instance Print Char where @@ -157,7 +139,6 @@ instance Print Double where instance Print HM.Parser.Abs.Ident where prt _ (HM.Parser.Abs.Ident i) = doc $ showString i - instance Print HM.Parser.Abs.Pattern where prt i = \case HM.Parser.Abs.PatternVar id_ -> prPrec i 0 (concatD [prt 0 id_]) diff --git a/src/HM/Typecheck.hs b/src/HM/Typecheck.hs index 2c3b6da..d414927 100644 --- a/src/HM/Typecheck.hs +++ b/src/HM/Typecheck.hs @@ -86,4 +86,4 @@ inferType scope (EApp e1 e2) = do TArrow type_ types -> do _ <- typecheck scope e2 type_ return types - _ -> Left ("expected type\n TArrow\nbut got type\n " <> show type1) \ No newline at end of file + _ -> Left ("expected type\n TArrow\nbut got type\n " <> show type1) From 35f42164cdf2e9e120090aae32a063c389b44f9e Mon Sep 17 00:00:00 2001 From: evermake Date: Tue, 3 Sep 2024 00:27:01 +0500 Subject: [PATCH 8/8] restore testing script from main --- test/HM/InterpretSpec.hs | 60 ++++++++++++++++++++++++++-------------- 1 file changed, 39 insertions(+), 21 deletions(-) diff --git a/test/HM/InterpretSpec.hs b/test/HM/InterpretSpec.hs index f79dcba..9f0f2c5 100644 --- a/test/HM/InterpretSpec.hs +++ b/test/HM/InterpretSpec.hs @@ -1,32 +1,50 @@ module HM.InterpretSpec where -import Test.Hspec import Control.Monad (forM_) -import HM.Interpret +import HM.Interpret +import System.Directory +import System.FilePath +import Test.Hspec + +spec :: Spec +spec = parallel $ do + describe "well-typed expressions" $ do + paths <- runIO (testFilesInDir "./test/files/well-typed") + forM_ paths $ \path -> it path $ do + contents <- readFile path + interpret contents `shouldSatisfy` isSuccess + + describe "ill-typed expressions" $ do + paths <- runIO (testFilesInDir "./test/files/ill-typed") + forM_ paths $ \path -> it path $ do + contents <- readFile path + interpret contents `shouldSatisfy` isTypeError isSuccess :: Result -> Bool -isSuccess Success{} = True +isSuccess Success {} = True isSuccess _ = False isTypeError :: Result -> Bool isTypeError (Failure TypecheckingError _) = True isTypeError _ = False -wellTypedPaths :: [FilePath] -wellTypedPaths = ["well-typed/1.lam", "well-typed/2.lam", "well-typed/7.lam", "well-typed/8.lam", "well-typed/9.lam"] - -illTypedPaths :: [FilePath] -illTypedPaths = ["ill-typed/1.lam", "ill-typed/2.lam", "ill-typed/7.lam", "ill-typed/8.lam", "ill-typed/9.lam"] - -spec :: Spec -spec = do - - describe "well-typed expressions" $ do - forM_ wellTypedPaths $ \path -> it path $ do - contents <- readFile ("test/files/" ++ path) - interpret contents `shouldSatisfy` isSuccess - - describe "ill-typed expressions" $ do - forM_ illTypedPaths $ \path -> it path $ do - contents <- readFile ("test/files/" ++ path) - interpret contents `shouldSatisfy` isTypeError +testFilesInDir :: FilePath -> IO [FilePath] +testFilesInDir dir = do + let isTestFile = \f -> return $ takeExtension f == ".lam" + dirWalk isTestFile dir + +dirWalk :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] +dirWalk filefunc top = do + isDirectory <- doesDirectoryExist top + if isDirectory + then do + -- Files preserving full path with `top` + files <- map (top ) <$> listDirectory top + paths <- mapM (dirWalk filefunc) files + return $ concat paths + else do + included <- filefunc top + return $ + if included + then [top] + else []