From a0f3dc647e5497e4769b036916f14329da2cc1d5 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Sat, 5 Mar 2022 20:37:50 +0300 Subject: [PATCH 01/39] CodeCombinators package, produceActionTable with combinators --- .../happy-code-combinators.cabal | 50 ++++++ .../src/Happy/Backend/CodeCombinators.hs | 143 ++++++++++++++++++ 2 files changed, 193 insertions(+) create mode 100644 packages/code-combinators/happy-code-combinators.cabal create mode 100644 packages/code-combinators/src/Happy/Backend/CodeCombinators.hs diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal new file mode 100644 index 00000000..2e88f024 --- /dev/null +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -0,0 +1,50 @@ +name: happy-code-combinators +version: 1.21.0 +license: BSD2 +license-file: LICENSE +copyright: (c) Andy Gill, Simon Marlow +author: Artem Zakharenko +maintainer: Artem Zakharenko +bug-reports: https://github.com/simonmar/happy/issues +stability: not-stable +homepage: https://www.haskell.org/happy/ +category: Development +cabal-version: >= 1.10 +build-type: Simple +synopsis: Code combinators for simple code generation + +Description: + Happy is a parser generator for Haskell. + Happy-Backend-LALR is responsible for code-generation: + It converts action and goto tables into LALR Haskell code. + + +tested-with: + GHC == 9.2.1 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 + GHC == 7.10.3 + GHC == 7.8.4 + GHC == 7.6.3 + GHC == 7.4.2 + GHC == 7.0.4 + +library + hs-source-dirs: src + + exposed-modules: Happy.Backend.CodeCombinators + + build-depends: base < 5, + array, + pretty, + template-haskell + + default-language: Haskell98 + default-extensions: CPP, MagicHash, FlexibleContexts + ghc-options: -Wall +-- other-modules: Paths_happy_backend_lalr diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs new file mode 100644 index 00000000..a18ad8c1 --- /dev/null +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} + +module Happy.Backend.CodeCombinators where + +import qualified Text.PrettyPrint as PP +import Language.Haskell.TH(Lit(..)) + +class CodeGen exp type_ name clause dec pat | exp -> type_ name clause dec pat, + type_ -> exp name clause dec pat, + name -> exp type_ clause dec pat, + clause -> exp type_ name dec pat, + dec -> exp type_ name clause pat, + pat -> exp type_ name clause dec + where + mkName :: String -> name + intE :: Int -> exp + + conE :: name -> exp + varE :: name -> exp + appE :: exp -> exp -> exp + + tupE :: [exp] -> exp + listE :: [exp] -> exp + + conT :: name -> type_ + varT :: name -> type_ + appT :: type_ -> type_ -> type_ + + litP :: Lit -> pat + varP :: name -> pat + tupP :: [pat] -> pat + conP :: name -> [pat] -> pat + + buildClause :: [pat] -> exp -> clause + + sigD :: name -> type_ -> dec + funD :: name -> [clause] -> dec + +newtype Prec = Prec Int + deriving (Eq, Ord, Show, Bounded) + +atomPrec, appPrec, noPrec :: Prec +atomPrec = Prec maxBound +appPrec = Prec 10 +noPrec = Prec (-1) + + +newtype DocExp = DocExp (Prec -> PP.Doc) +newtype DocType = DocType (Prec -> PP.Doc) +newtype DocPat = DocPat (Prec -> PP.Doc) + +newtype DocName = DocName PP.Doc + deriving (Eq, Show) +newtype DocClause = DocClause PP.Doc + deriving (Eq, Show) +newtype DocDec = DocDec PP.Doc + deriving (Eq, Show) + +instance CodeGen DocExp DocType DocName DocClause DocDec DocPat where + mkName :: String -> DocName + mkName name = DocName $ PP.text name + + intE :: Int -> DocExp + intE num = DocExp (\_ -> parensIf (num < 0) (PP.int num)) + + conE :: DocName -> DocExp + conE (DocName name) = DocExp $ \_ -> name + + varE :: DocName -> DocExp + varE (DocName name) = DocExp $ \_ -> name + + appE :: DocExp -> DocExp -> DocExp + appE (DocExp e1) (DocExp e2) = DocExp $ \p -> parensIf (p > appPrec) $ + PP.sep [e1 appPrec, e2 atomPrec] + + + tupE :: [DocExp] -> DocExp + tupE ds = DocExp $ \_ -> PP.parens $ PP.sep $ PP.punctuate PP.comma $ + [d noPrec | DocExp d <- ds] + + listE :: [DocExp] -> DocExp + listE ds = DocExp $ \_ -> PP.brackets $ PP.sep $ PP.punctuate PP.comma $ + [d noPrec | DocExp d <- ds] + + conT :: DocName -> DocType + conT (DocName name) = DocType $ \_ -> name + + varT :: DocName -> DocType + varT (DocName name) = DocType $ \_ -> name + + appT :: DocType -> DocType -> DocType + appT (DocType t1) (DocType t2) = DocType $ \p -> parensIf (p > appPrec) $ + PP.sep [t1 appPrec, t2 atomPrec] + + litP :: Lit -> DocPat + litP (CharL c) = DocPat $ \_ -> PP.text ['\'', c, '\''] + litP (StringL s) = DocPat $ \_ -> PP.text "\"" <> PP.text s <> PP.text "\"" + litP (IntegerL n) = DocPat $ \_ -> parensIf (n < 0) $ PP.text $ show n + + varP :: DocName -> DocPat + varP (DocName name) = DocPat $ \_ -> name + + tupP :: [DocPat] -> DocPat + tupP ps = DocPat $ \_ -> + PP.parens $ PP.sep $ PP.punctuate PP.comma [p noPrec | DocPat p <- ps] + + conP :: DocName -> [DocPat] -> DocPat + conP (DocName name) ps = DocPat $ \p -> parensIf (p > appPrec) $ + name PP.<+> PP.sep [p atomPrec | DocPat p <- ps] + + buildClause :: [DocPat] -> DocExp -> DocClause + buildClause ps (DocExp exp) = DocClause $ PP.sep [p noPrec | DocPat p <- ps] PP.<+> + PP.text "=" PP.<+> exp noPrec + + sigD :: DocName -> DocType -> DocDec + sigD (DocName name) (DocType type_) = DocDec $ name PP.<+> PP.text "::" PP.<+> (type_ noPrec) + + funD :: DocName -> [DocClause] -> DocDec + funD (DocName name) cls = DocDec $ foldr1 (<>) $ PP.punctuate (PP.text "\n") + [name PP.<+> cl | DocClause cl <- cls] + + +fromTextDetails :: PP.TextDetails -> ShowS +fromTextDetails td = + case td of + PP.Chr c -> (c:) + PP.Str str -> (str++) + PP.PStr str -> (str++) + +renderDocDecs :: [[DocDec]] -> ShowS +renderDocDecs dss = + PP.fullRender PP.PageMode 80 1.5 (\td s -> fromTextDetails td . s) id d + where + d = PP.vcat (map renderGroup dss) + renderGroup ds = PP.vcat [ d1 | DocDec d1 <- ds ] PP.$$ PP.text "" + +parensIf :: Bool -> PP.Doc -> PP.Doc +parensIf True = PP.parens +parensIf False = id From 414b583772afcc7840d701557e714f2c7d5979ce Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Sat, 5 Mar 2022 20:58:43 +0300 Subject: [PATCH 02/39] Commit unstaged from previous commit --- packages/backend-lalr/happy-backend-lalr.cabal | 3 ++- .../src/Happy/Backend/LALR/ProduceCode.lhs | 18 ++++++++++++++++-- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/packages/backend-lalr/happy-backend-lalr.cabal b/packages/backend-lalr/happy-backend-lalr.cabal index cc9eeae4..df96c6ed 100644 --- a/packages/backend-lalr/happy-backend-lalr.cabal +++ b/packages/backend-lalr/happy-backend-lalr.cabal @@ -49,7 +49,8 @@ library array, happy-codegen-common == 1.21.0, happy-grammar == 1.21.0, - happy-tabular == 1.21.0 + happy-tabular == 1.21.0, + happy-code-combinators == 1.21.0 default-language: Haskell98 default-extensions: CPP, MagicHash, FlexibleContexts diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 30d8a9b6..8b79add2 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -25,6 +25,8 @@ The code generator. > import Data.Array.MArray ( MArray(..), freeze, readArray, writeArray ) > import Data.Array.IArray ( Array, IArray(..), (!), array, assocs, elems ) +> import Happy.Backend.CodeCombinators + %----------------------------------------------------------------------------- Produce the complete output file. @@ -581,8 +583,20 @@ machinery to discard states in the parser... > produceActionTable TargetArrayBased > = produceActionArray > . produceReduceArray -> . str "happy_n_terms = " . shows n_terminals . str " :: Prelude.Int\n" -> . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Prelude.Int\n\n" +> . renderDocDecs [ +> [ +> sigD happy_n_terms_name (conT $ mkName "Prelude.Int"), +> funD happy_n_terms_name [buildClause [] (intE n_terminals)] +> ], +> [ +> sigD happy_n_nonterms_name (conT $ mkName "Prelude.Int"), +> funD happy_n_nonterms_name [buildClause [] (intE n_nonterminals)] +> ] +> ] +> . nl +> where happy_n_terms_name = mkName "happy_n_terms" +> happy_n_nonterms_name = mkName "happy_n_nonterms_name" + > > produceExpListPerState > = produceExpListArray From ce71cab7c21859e2648402a1476f700ccd5d3d55 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Sun, 6 Mar 2022 15:14:13 +0300 Subject: [PATCH 03/39] add where section for CodeCombinators.clause --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 4 +-- .../src/Happy/Backend/CodeCombinators.hs | 28 ++++++++++--------- 2 files changed, 17 insertions(+), 15 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 8b79add2..cb24528c 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -586,11 +586,11 @@ machinery to discard states in the parser... > . renderDocDecs [ > [ > sigD happy_n_terms_name (conT $ mkName "Prelude.Int"), -> funD happy_n_terms_name [buildClause [] (intE n_terminals)] +> funD happy_n_terms_name [clause [] (intE n_terminals) []] > ], > [ > sigD happy_n_nonterms_name (conT $ mkName "Prelude.Int"), -> funD happy_n_nonterms_name [buildClause [] (intE n_nonterminals)] +> funD happy_n_nonterms_name [clause [] (intE n_nonterminals) []] > ] > ] > . nl diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index a18ad8c1..762dfa3e 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -5,7 +5,6 @@ {-# LANGUAGE InstanceSigs #-} module Happy.Backend.CodeCombinators where - import qualified Text.PrettyPrint as PP import Language.Haskell.TH(Lit(..)) @@ -24,7 +23,7 @@ class CodeGen exp type_ name clause dec pat | exp -> type_ name clause dec pa appE :: exp -> exp -> exp tupE :: [exp] -> exp - listE :: [exp] -> exp + listE :: [exp] -> exp conT :: name -> type_ varT :: name -> type_ @@ -35,7 +34,7 @@ class CodeGen exp type_ name clause dec pat | exp -> type_ name clause dec pa tupP :: [pat] -> pat conP :: name -> [pat] -> pat - buildClause :: [pat] -> exp -> clause + clause :: [pat] -> exp -> [dec] -> clause sigD :: name -> type_ -> dec funD :: name -> [clause] -> dec @@ -97,8 +96,8 @@ instance CodeGen DocExp DocType DocName DocClause DocDec DocPat where PP.sep [t1 appPrec, t2 atomPrec] litP :: Lit -> DocPat - litP (CharL c) = DocPat $ \_ -> PP.text ['\'', c, '\''] - litP (StringL s) = DocPat $ \_ -> PP.text "\"" <> PP.text s <> PP.text "\"" + litP (CharL c) = DocPat $ \_ -> PP.quotes $ PP.text [c] + litP (StringL s) = DocPat $ \_ -> PP.doubleQuotes $ PP.text s litP (IntegerL n) = DocPat $ \_ -> parensIf (n < 0) $ PP.text $ show n varP :: DocName -> DocPat @@ -112,19 +111,22 @@ instance CodeGen DocExp DocType DocName DocClause DocDec DocPat where conP (DocName name) ps = DocPat $ \p -> parensIf (p > appPrec) $ name PP.<+> PP.sep [p atomPrec | DocPat p <- ps] - buildClause :: [DocPat] -> DocExp -> DocClause - buildClause ps (DocExp exp) = DocClause $ PP.sep [p noPrec | DocPat p <- ps] PP.<+> - PP.text "=" PP.<+> exp noPrec + clause :: [DocPat] -> DocExp -> [DocDec] -> DocClause + clause ps (DocExp exp) decs = DocClause $ (PP.sep [p noPrec | DocPat p <- ps] PP.<+> + PP.text "=" PP.<+> exp noPrec) PP.$+$ PP.nest 4 whereSection + where whereSection = case decs of + [] -> PP.empty + _ -> PP.text "where" PP.$+$ + foldr (PP.$+$) PP.empty [PP.nest 4 dec | DocDec dec <- decs] sigD :: DocName -> DocType -> DocDec - sigD (DocName name) (DocType type_) = DocDec $ name PP.<+> PP.text "::" PP.<+> (type_ noPrec) + sigD (DocName name) (DocType type_) = DocDec $ name PP.<+> PP.text "::" PP.<+> type_ noPrec funD :: DocName -> [DocClause] -> DocDec - funD (DocName name) cls = DocDec $ foldr1 (<>) $ PP.punctuate (PP.text "\n") - [name PP.<+> cl | DocClause cl <- cls] + funD (DocName name) cls = DocDec $ foldr1 (PP.$+$) [name PP.<+> cl | DocClause cl <- cls] -fromTextDetails :: PP.TextDetails -> ShowS +fromTextDetails :: PP.TextDetails -> ShowS fromTextDetails td = case td of PP.Chr c -> (c:) @@ -136,7 +138,7 @@ renderDocDecs dss = PP.fullRender PP.PageMode 80 1.5 (\td s -> fromTextDetails td . s) id d where d = PP.vcat (map renderGroup dss) - renderGroup ds = PP.vcat [ d1 | DocDec d1 <- ds ] PP.$$ PP.text "" + renderGroup ds = PP.vcat [ d1 | DocDec d1 <- ds ] PP.$+$ PP.text "" parensIf :: Bool -> PP.Doc -> PP.Doc parensIf True = PP.parens From fa087a3cca7233cac84bc8ec1495a5c3db3324d4 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Sun, 6 Mar 2022 21:52:03 +0300 Subject: [PATCH 04/39] rewrite produceExpListPerState using code-combinators --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 115 +++++++++++++++--- .../src/Happy/Backend/CodeCombinators.hs | 54 +++++--- 2 files changed, 137 insertions(+), 32 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index cb24528c..a9009042 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -597,26 +597,111 @@ machinery to discard states in the parser... > where happy_n_terms_name = mkName "happy_n_terms" > happy_n_nonterms_name = mkName "happy_n_nonterms_name" -> + +% {-# NOINLINE happyExpListPerState #-} +% happyExpListPerState st = token_strs_expected +% where token_strs = " . str (show $ elems token_names') +% bit_start = st Prelude.* " . str (show nr_tokens) +% bit_end = (st Prelude.+ 1) Prelude.* " . str (show nr_tokens) +% read_bit = readArrayBit happyExpList +% bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] +% bits_indexed = Prelude.zip bits [0..nr_tokens - 1] +% token_strs_expected = Prelude.concatMap f bits_indexed +% f (Prelude.False, _) = [] +% f (Prelude.True, nr) = [token_strs Prelude.!! nr] + > produceExpListPerState > = produceExpListArray > . str "{-# NOINLINE happyExpListPerState #-}\n" -> . str "happyExpListPerState st =\n" -> . str " token_strs_expected\n" -> . str " where token_strs = " . str (show $ elems token_names') . str "\n" -> . str " bit_start = st Prelude.* " . str (show nr_tokens) . str "\n" -> . str " bit_end = (st Prelude.+ 1) Prelude.* " . str (show nr_tokens) . str "\n" -> . str " read_bit = readArrayBit happyExpList\n" -> . str " bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1]\n" -> . str " bits_indexed = Prelude.zip bits [0.." -> . str (show (nr_tokens - 1)) . str "]\n" -> . str " token_strs_expected = Prelude.concatMap f bits_indexed\n" -> . str " f (Prelude.False, _) = []\n" -> . str " f (Prelude.True, nr) = [token_strs Prelude.!! nr]\n" -> . str "\n" +> . (renderDocDecs [[happy_exp_list_per_state_dec]]) +> . nl +> . nl > where (first_token, last_token) = bounds token_names' > nr_tokens = last_token - first_token + 1 -> +> +> --happyExpListPerState st = token_strs_expected +> happy_exp_list_per_state_name = mkName "happyExpListPerState" +> happy_exp_list_per_state_dec = funD happy_exp_list_per_state_name [clause [st_pat] (varE token_strs_expected_name) +> [ +> token_strs_dec, +> bit_start_dec, +> bit_end_dec, +> read_bit_dec, +> bits_dec, +> bits_indexed_dec, +> f_dec, +> token_strs_expected_dec +> ] +> ] :: DocDec +> st_name = mkName "st" +> st_var = varE st_name +> st_pat = varP st_name +> mulE = varE $ mkName "(Prelude.*)" +> addE = varE $ mkName "(Prelude.+)" +> subE = varE $ mkName "(Prelude.-)" +> +> --token_strs = elems token_names' +> token_strs_name = mkName "token_strs" +> token_strs_dec = funD token_strs_name [clause [] token_strs_exp []] :: DocDec +> where token_strs_exp = listE [stringE str_elem | str_elem <- elems token_names'] +> +> --bit_start = st Prelude.* nr_tokens +> bit_start_name = mkName "bit_start" +> bit_start_dec = funD bit_start_name [clause [] bit_start_exp []] :: DocDec +> where bit_start_exp = appE (appE mulE st_var) (intE nr_tokens) +> +> --bit_end = (st Prelude.+ 1) Prelude.* nr_tokens +> bit_end_name = mkName "bit_end" +> bit_end_dec = funD bit_end_name [clause [] bit_end_exp []] :: DocDec +> where bit_end_exp = appE (appE mulE (appE (appE addE st_var) (intE 1))) (intE nr_tokens) +> +> --read_bit = readArrayBit happyExpList +> read_bit_name = mkName "read_bit" +> read_bit_dec = funD read_bit_name [clause [] read_bit_exp []] :: DocDec +> where read_bit_exp = appE (varE $ mkName "readArrayBit") (varE $ mkName "happyExpList") +> +> --bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] +> bits_name = mkName "bits" +> bits_dec = funD bits_name [clause [] bits_exp []] :: DocDec +> where bits_exp = appE ( +> appE (varE $ mkName "Prelude.map") +> (varE $ mkName "read_bit") +> ) +> ( +> arithSeqE ( +> FromToR +> (varE bit_start_name) +> (appE (appE subE (varE bit_end_name)) (intE 1))) +> ) +> --bits_indexed = Prelude.zip bits [0... nr_tokens - 1] +> bits_indexed_name = mkName "bits_indexed" +> bits_indexed_dec = funD bits_indexed_name [clause [] bits_indexed_exp []] :: DocDec +> where bits_indexed_exp = appE +> (appE (varE $ mkName "Prelude.zip") (varE bits_name)) +> (arithSeqE $ FromToR (intE 0) (intE $ nr_tokens - 1)) +> +> --f (Prelude.False, _) = []\n" +> --f (Prelude.True, nr) = [token_strs Prelude.!! nr]\n +> f_name = mkName "f" +> f_dec = funD f_name [clause1, clause2] +> where clause1 = clause [tupP [conP (mkName "Prelude.False") [], wildP]] (conE $ mkName "[]") [] +> clause2 = clause [tupP [conP (mkName "Prelude.True") [], varP nr]] exp2 [] +> nr = mkName "nr" +> exp2 = listE [ +> appE ( +> appE (varE $ mkName "(Prelude.!!)") +> (varE token_strs_name) +> ) +> (varE nr) +> ] +> --token_strs_expected = Prelude.concatMap f token_strs_name = mkName "token_strs" +> token_strs_expected_name = mkName "token_strs_expected" +> token_strs_expected_dec = funD token_strs_expected_name [clause [] token_strs_expected_exp []] :: DocDec +> where token_strs_expected_exp = appE ( +> appE (varE $ mkName "Prelude.concatMap") +> (varE f_name) +> ) +> (varE bits_indexed_name) > produceStateFunction goto' (state, acts) > = foldr (.) id (map produceActions assocs_acts) > . foldr (.) id (map produceGotos (assocs gotos)) diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 762dfa3e..866d21f8 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -6,33 +6,37 @@ module Happy.Backend.CodeCombinators where import qualified Text.PrettyPrint as PP -import Language.Haskell.TH(Lit(..)) - -class CodeGen exp type_ name clause dec pat | exp -> type_ name clause dec pat, - type_ -> exp name clause dec pat, - name -> exp type_ clause dec pat, - clause -> exp type_ name dec pat, - dec -> exp type_ name clause pat, - pat -> exp type_ name clause dec - where +import qualified Language.Haskell.TH as TH + +class CodeGen exp type_ name clause dec pat range | exp -> type_ name clause dec pat range, + type_ -> exp name clause dec pat range, + name -> exp type_ clause dec pat range, + clause -> exp type_ name dec pat range, + dec -> exp type_ name clause pat range, + pat -> exp type_ name clause dec range, + range -> exp type_ name clause dec pat range + where mkName :: String -> name intE :: Int -> exp + stringE :: String -> exp conE :: name -> exp varE :: name -> exp appE :: exp -> exp -> exp - tupE :: [exp] -> exp - listE :: [exp] -> exp + tupE :: [exp] -> exp + listE :: [exp] -> exp + arithSeqE :: range -> exp conT :: name -> type_ varT :: name -> type_ appT :: type_ -> type_ -> type_ - litP :: Lit -> pat + litP :: TH.Lit -> pat varP :: name -> pat tupP :: [pat] -> pat conP :: name -> [pat] -> pat + wildP :: pat clause :: [pat] -> exp -> [dec] -> clause @@ -59,13 +63,21 @@ newtype DocClause = DocClause PP.Doc newtype DocDec = DocDec PP.Doc deriving (Eq, Show) -instance CodeGen DocExp DocType DocName DocClause DocDec DocPat where +data DocRange = FromR DocExp + | FromThenR DocExp DocExp + | FromToR DocExp DocExp + | FromThenToR DocExp DocExp DocExp + +instance CodeGen DocExp DocType DocName DocClause DocDec DocPat DocRange where mkName :: String -> DocName mkName name = DocName $ PP.text name intE :: Int -> DocExp intE num = DocExp (\_ -> parensIf (num < 0) (PP.int num)) + stringE :: String -> DocExp + stringE str = DocExp (\_ -> PP.doubleQuotes $ PP.text str) + conE :: DocName -> DocExp conE (DocName name) = DocExp $ \_ -> name @@ -85,6 +97,9 @@ instance CodeGen DocExp DocType DocName DocClause DocDec DocPat where listE ds = DocExp $ \_ -> PP.brackets $ PP.sep $ PP.punctuate PP.comma $ [d noPrec | DocExp d <- ds] + arithSeqE :: DocRange -> DocExp + arithSeqE (FromToR (DocExp e1) (DocExp e2)) = DocExp $ \_ -> PP.brackets $ e1 noPrec <> PP.text ".." <> e2 noPrec + conT :: DocName -> DocType conT (DocName name) = DocType $ \_ -> name @@ -95,10 +110,10 @@ instance CodeGen DocExp DocType DocName DocClause DocDec DocPat where appT (DocType t1) (DocType t2) = DocType $ \p -> parensIf (p > appPrec) $ PP.sep [t1 appPrec, t2 atomPrec] - litP :: Lit -> DocPat - litP (CharL c) = DocPat $ \_ -> PP.quotes $ PP.text [c] - litP (StringL s) = DocPat $ \_ -> PP.doubleQuotes $ PP.text s - litP (IntegerL n) = DocPat $ \_ -> parensIf (n < 0) $ PP.text $ show n + litP :: TH.Lit -> DocPat + litP (TH.CharL c) = DocPat $ \_ -> PP.quotes $ PP.text [c] + litP (TH.StringL s) = DocPat $ \_ -> PP.doubleQuotes $ PP.text s + litP (TH.IntegerL n) = DocPat $ \_ -> parensIf (n < 0) $ PP.text $ show n varP :: DocName -> DocPat varP (DocName name) = DocPat $ \_ -> name @@ -110,6 +125,8 @@ instance CodeGen DocExp DocType DocName DocClause DocDec DocPat where conP :: DocName -> [DocPat] -> DocPat conP (DocName name) ps = DocPat $ \p -> parensIf (p > appPrec) $ name PP.<+> PP.sep [p atomPrec | DocPat p <- ps] + wildP :: DocPat + wildP = DocPat $ \_ -> PP.text "_" clause :: [DocPat] -> DocExp -> [DocDec] -> DocClause clause ps (DocExp exp) decs = DocClause $ (PP.sep [p noPrec | DocPat p <- ps] PP.<+> @@ -133,6 +150,9 @@ fromTextDetails td = PP.Str str -> (str++) PP.PStr str -> (str++) +renderDocDec :: DocDec -> ShowS +renderDocDec (DocDec dec) = \_ -> PP.render dec + renderDocDecs :: [[DocDec]] -> ShowS renderDocDecs dss = PP.fullRender PP.PageMode 80 1.5 (\td s -> fromTextDetails td . s) id d From 313745ccbca093602d368d02093fc803c03421f4 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Mon, 7 Mar 2022 22:22:50 +0300 Subject: [PATCH 05/39] Add associated type families to CodeGen class, move extensions to cabal file --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 3 +- .../happy-code-combinators.cabal | 2 +- .../src/Happy/Backend/CodeCombinators.hs | 88 ++++++++++--------- 3 files changed, 47 insertions(+), 46 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index a9009042..11cee278 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -613,8 +613,7 @@ machinery to discard states in the parser... > produceExpListPerState > = produceExpListArray > . str "{-# NOINLINE happyExpListPerState #-}\n" -> . (renderDocDecs [[happy_exp_list_per_state_dec]]) -> . nl +> . (renderDocDec happy_exp_list_per_state_dec) > . nl > where (first_token, last_token) = bounds token_names' > nr_tokens = last_token - first_token + 1 diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index 2e88f024..6d91b5cd 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -45,6 +45,6 @@ library template-haskell default-language: Haskell98 - default-extensions: CPP, MagicHash, FlexibleContexts + default-extensions: CPP, MagicHash, InstanceSigs, TypeFamilyDependencies ghc-options: -Wall -- other-modules: Paths_happy_backend_lalr diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 866d21f8..54f59fa5 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -1,48 +1,43 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE InstanceSigs #-} - module Happy.Backend.CodeCombinators where + import qualified Text.PrettyPrint as PP import qualified Language.Haskell.TH as TH -class CodeGen exp type_ name clause dec pat range | exp -> type_ name clause dec pat range, - type_ -> exp name clause dec pat range, - name -> exp type_ clause dec pat range, - clause -> exp type_ name dec pat range, - dec -> exp type_ name clause pat range, - pat -> exp type_ name clause dec range, - range -> exp type_ name clause dec pat range - where - mkName :: String -> name - intE :: Int -> exp - stringE :: String -> exp - - conE :: name -> exp - varE :: name -> exp - appE :: exp -> exp -> exp - - tupE :: [exp] -> exp - listE :: [exp] -> exp - arithSeqE :: range -> exp - - conT :: name -> type_ - varT :: name -> type_ - appT :: type_ -> type_ -> type_ - - litP :: TH.Lit -> pat - varP :: name -> pat - tupP :: [pat] -> pat - conP :: name -> [pat] -> pat - wildP :: pat - - clause :: [pat] -> exp -> [dec] -> clause - - sigD :: name -> type_ -> dec - funD :: name -> [clause] -> dec - +class CodeGen e where + type NameT e = n | n -> e + type RangeT e = r | r -> e + type TypeT e = t | t -> e + type PatT e = p | p -> e + type DecT e = d | d -> e + type ClauseT e = c | c -> e + + mkName :: String -> NameT e + intE :: Int -> e + stringE :: String -> e + + conE :: NameT e -> e + varE :: NameT e -> e + appE :: e -> e -> e + + tupE :: [e] -> e + listE :: [e] -> e + arithSeqE :: RangeT e -> e + + conT :: NameT e -> TypeT e + varT :: NameT e -> TypeT e + appT :: TypeT e -> TypeT e -> TypeT e + + litP :: TH.Lit -> PatT e + varP :: NameT e -> PatT e + tupP :: [PatT e] -> PatT e + conP :: NameT e -> [PatT e] -> PatT e + wildP :: PatT e + + clause :: [PatT e] -> e -> [DecT e] -> ClauseT e + + sigD :: NameT e -> TypeT e -> DecT e + funD :: NameT e -> [ClauseT e] -> DecT e + newtype Prec = Prec Int deriving (Eq, Ord, Show, Bounded) @@ -68,7 +63,14 @@ data DocRange = FromR DocExp | FromToR DocExp DocExp | FromThenToR DocExp DocExp DocExp -instance CodeGen DocExp DocType DocName DocClause DocDec DocPat DocRange where +instance CodeGen DocExp where + type NameT DocExp = DocName + type RangeT DocExp = DocRange + type TypeT DocExp = DocType + type PatT DocExp = DocPat + type DecT DocExp = DocDec + type ClauseT DocExp = DocClause + mkName :: String -> DocName mkName name = DocName $ PP.text name @@ -151,7 +153,7 @@ fromTextDetails td = PP.PStr str -> (str++) renderDocDec :: DocDec -> ShowS -renderDocDec (DocDec dec) = \_ -> PP.render dec +renderDocDec (DocDec dec) = showString $ PP.render dec renderDocDecs :: [[DocDec]] -> ShowS renderDocDecs dss = From 5be4b659245a9ca19ffc8aff88319b76789ddca5 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Mon, 7 Mar 2022 22:33:15 +0300 Subject: [PATCH 06/39] split CodeCombinators module --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 1 + .../happy-code-combinators.cabal | 3 +- .../src/Happy/Backend/CodeCombinators.hs | 129 ----------------- .../Happy/Backend/CodeCombinators/Syntax.hs | 134 ++++++++++++++++++ 4 files changed, 137 insertions(+), 130 deletions(-) create mode 100644 packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 11cee278..ddc43698 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -26,6 +26,7 @@ The code generator. > import Data.Array.IArray ( Array, IArray(..), (!), array, assocs, elems ) > import Happy.Backend.CodeCombinators +> import Happy.Backend.CodeCombinators.Syntax %----------------------------------------------------------------------------- Produce the complete output file. diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index 6d91b5cd..6f7792b7 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -37,7 +37,8 @@ tested-with: library hs-source-dirs: src - exposed-modules: Happy.Backend.CodeCombinators + exposed-modules: Happy.Backend.CodeCombinators, + Happy.Backend.CodeCombinators.Syntax build-depends: base < 5, array, diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 54f59fa5..5e0d8cbd 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -1,6 +1,5 @@ module Happy.Backend.CodeCombinators where -import qualified Text.PrettyPrint as PP import qualified Language.Haskell.TH as TH class CodeGen e where @@ -37,131 +36,3 @@ class CodeGen e where sigD :: NameT e -> TypeT e -> DecT e funD :: NameT e -> [ClauseT e] -> DecT e - -newtype Prec = Prec Int - deriving (Eq, Ord, Show, Bounded) - -atomPrec, appPrec, noPrec :: Prec -atomPrec = Prec maxBound -appPrec = Prec 10 -noPrec = Prec (-1) - - -newtype DocExp = DocExp (Prec -> PP.Doc) -newtype DocType = DocType (Prec -> PP.Doc) -newtype DocPat = DocPat (Prec -> PP.Doc) - -newtype DocName = DocName PP.Doc - deriving (Eq, Show) -newtype DocClause = DocClause PP.Doc - deriving (Eq, Show) -newtype DocDec = DocDec PP.Doc - deriving (Eq, Show) - -data DocRange = FromR DocExp - | FromThenR DocExp DocExp - | FromToR DocExp DocExp - | FromThenToR DocExp DocExp DocExp - -instance CodeGen DocExp where - type NameT DocExp = DocName - type RangeT DocExp = DocRange - type TypeT DocExp = DocType - type PatT DocExp = DocPat - type DecT DocExp = DocDec - type ClauseT DocExp = DocClause - - mkName :: String -> DocName - mkName name = DocName $ PP.text name - - intE :: Int -> DocExp - intE num = DocExp (\_ -> parensIf (num < 0) (PP.int num)) - - stringE :: String -> DocExp - stringE str = DocExp (\_ -> PP.doubleQuotes $ PP.text str) - - conE :: DocName -> DocExp - conE (DocName name) = DocExp $ \_ -> name - - varE :: DocName -> DocExp - varE (DocName name) = DocExp $ \_ -> name - - appE :: DocExp -> DocExp -> DocExp - appE (DocExp e1) (DocExp e2) = DocExp $ \p -> parensIf (p > appPrec) $ - PP.sep [e1 appPrec, e2 atomPrec] - - - tupE :: [DocExp] -> DocExp - tupE ds = DocExp $ \_ -> PP.parens $ PP.sep $ PP.punctuate PP.comma $ - [d noPrec | DocExp d <- ds] - - listE :: [DocExp] -> DocExp - listE ds = DocExp $ \_ -> PP.brackets $ PP.sep $ PP.punctuate PP.comma $ - [d noPrec | DocExp d <- ds] - - arithSeqE :: DocRange -> DocExp - arithSeqE (FromToR (DocExp e1) (DocExp e2)) = DocExp $ \_ -> PP.brackets $ e1 noPrec <> PP.text ".." <> e2 noPrec - - conT :: DocName -> DocType - conT (DocName name) = DocType $ \_ -> name - - varT :: DocName -> DocType - varT (DocName name) = DocType $ \_ -> name - - appT :: DocType -> DocType -> DocType - appT (DocType t1) (DocType t2) = DocType $ \p -> parensIf (p > appPrec) $ - PP.sep [t1 appPrec, t2 atomPrec] - - litP :: TH.Lit -> DocPat - litP (TH.CharL c) = DocPat $ \_ -> PP.quotes $ PP.text [c] - litP (TH.StringL s) = DocPat $ \_ -> PP.doubleQuotes $ PP.text s - litP (TH.IntegerL n) = DocPat $ \_ -> parensIf (n < 0) $ PP.text $ show n - - varP :: DocName -> DocPat - varP (DocName name) = DocPat $ \_ -> name - - tupP :: [DocPat] -> DocPat - tupP ps = DocPat $ \_ -> - PP.parens $ PP.sep $ PP.punctuate PP.comma [p noPrec | DocPat p <- ps] - - conP :: DocName -> [DocPat] -> DocPat - conP (DocName name) ps = DocPat $ \p -> parensIf (p > appPrec) $ - name PP.<+> PP.sep [p atomPrec | DocPat p <- ps] - wildP :: DocPat - wildP = DocPat $ \_ -> PP.text "_" - - clause :: [DocPat] -> DocExp -> [DocDec] -> DocClause - clause ps (DocExp exp) decs = DocClause $ (PP.sep [p noPrec | DocPat p <- ps] PP.<+> - PP.text "=" PP.<+> exp noPrec) PP.$+$ PP.nest 4 whereSection - where whereSection = case decs of - [] -> PP.empty - _ -> PP.text "where" PP.$+$ - foldr (PP.$+$) PP.empty [PP.nest 4 dec | DocDec dec <- decs] - - sigD :: DocName -> DocType -> DocDec - sigD (DocName name) (DocType type_) = DocDec $ name PP.<+> PP.text "::" PP.<+> type_ noPrec - - funD :: DocName -> [DocClause] -> DocDec - funD (DocName name) cls = DocDec $ foldr1 (PP.$+$) [name PP.<+> cl | DocClause cl <- cls] - - -fromTextDetails :: PP.TextDetails -> ShowS -fromTextDetails td = - case td of - PP.Chr c -> (c:) - PP.Str str -> (str++) - PP.PStr str -> (str++) - -renderDocDec :: DocDec -> ShowS -renderDocDec (DocDec dec) = showString $ PP.render dec - -renderDocDecs :: [[DocDec]] -> ShowS -renderDocDecs dss = - PP.fullRender PP.PageMode 80 1.5 (\td s -> fromTextDetails td . s) id d - where - d = PP.vcat (map renderGroup dss) - renderGroup ds = PP.vcat [ d1 | DocDec d1 <- ds ] PP.$+$ PP.text "" - -parensIf :: Bool -> PP.Doc -> PP.Doc -parensIf True = PP.parens -parensIf False = id diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs new file mode 100644 index 00000000..3c399f20 --- /dev/null +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -0,0 +1,134 @@ +module Happy.Backend.CodeCombinators.Syntax where + +import Happy.Backend.CodeCombinators +import qualified Text.PrettyPrint as PP +import qualified Language.Haskell.TH as TH + + +newtype Prec = Prec Int + deriving (Eq, Ord, Show, Bounded) + +atomPrec, appPrec, noPrec :: Prec +atomPrec = Prec maxBound +appPrec = Prec 10 +noPrec = Prec (-1) + + +newtype DocExp = DocExp (Prec -> PP.Doc) +newtype DocType = DocType (Prec -> PP.Doc) +newtype DocPat = DocPat (Prec -> PP.Doc) + +newtype DocName = DocName PP.Doc + deriving (Eq, Show) +newtype DocClause = DocClause PP.Doc + deriving (Eq, Show) +newtype DocDec = DocDec PP.Doc + deriving (Eq, Show) + +data DocRange = FromR DocExp + | FromThenR DocExp DocExp + | FromToR DocExp DocExp + | FromThenToR DocExp DocExp DocExp + +instance CodeGen DocExp where + type NameT DocExp = DocName + type RangeT DocExp = DocRange + type TypeT DocExp = DocType + type PatT DocExp = DocPat + type DecT DocExp = DocDec + type ClauseT DocExp = DocClause + + mkName :: String -> DocName + mkName name = DocName $ PP.text name + + intE :: Int -> DocExp + intE num = DocExp (\_ -> parensIf (num < 0) (PP.int num)) + + stringE :: String -> DocExp + stringE str = DocExp (\_ -> PP.doubleQuotes $ PP.text str) + + conE :: DocName -> DocExp + conE (DocName name) = DocExp $ \_ -> name + + varE :: DocName -> DocExp + varE (DocName name) = DocExp $ \_ -> name + + appE :: DocExp -> DocExp -> DocExp + appE (DocExp e1) (DocExp e2) = DocExp $ \p -> parensIf (p > appPrec) $ + PP.sep [e1 appPrec, e2 atomPrec] + + + tupE :: [DocExp] -> DocExp + tupE ds = DocExp $ \_ -> PP.parens $ PP.sep $ PP.punctuate PP.comma $ + [d noPrec | DocExp d <- ds] + + listE :: [DocExp] -> DocExp + listE ds = DocExp $ \_ -> PP.brackets $ PP.sep $ PP.punctuate PP.comma $ + [d noPrec | DocExp d <- ds] + + arithSeqE :: DocRange -> DocExp + arithSeqE (FromToR (DocExp e1) (DocExp e2)) = DocExp $ \_ -> PP.brackets $ e1 noPrec <> PP.text ".." <> e2 noPrec + + conT :: DocName -> DocType + conT (DocName name) = DocType $ \_ -> name + + varT :: DocName -> DocType + varT (DocName name) = DocType $ \_ -> name + + appT :: DocType -> DocType -> DocType + appT (DocType t1) (DocType t2) = DocType $ \p -> parensIf (p > appPrec) $ + PP.sep [t1 appPrec, t2 atomPrec] + + litP :: TH.Lit -> DocPat + litP (TH.CharL c) = DocPat $ \_ -> PP.quotes $ PP.text [c] + litP (TH.StringL s) = DocPat $ \_ -> PP.doubleQuotes $ PP.text s + litP (TH.IntegerL n) = DocPat $ \_ -> parensIf (n < 0) $ PP.text $ show n + + varP :: DocName -> DocPat + varP (DocName name) = DocPat $ \_ -> name + + tupP :: [DocPat] -> DocPat + tupP ps = DocPat $ \_ -> + PP.parens $ PP.sep $ PP.punctuate PP.comma [p noPrec | DocPat p <- ps] + + conP :: DocName -> [DocPat] -> DocPat + conP (DocName name) ps = DocPat $ \p -> parensIf (p > appPrec) $ + name PP.<+> PP.sep [p atomPrec | DocPat p <- ps] + wildP :: DocPat + wildP = DocPat $ \_ -> PP.text "_" + + clause :: [DocPat] -> DocExp -> [DocDec] -> DocClause + clause ps (DocExp exp) decs = DocClause $ (PP.sep [p noPrec | DocPat p <- ps] PP.<+> + PP.text "=" PP.<+> exp noPrec) PP.$+$ PP.nest 4 whereSection + where whereSection = case decs of + [] -> PP.empty + _ -> PP.text "where" PP.$+$ + foldr (PP.$+$) PP.empty [PP.nest 4 dec | DocDec dec <- decs] + + sigD :: DocName -> DocType -> DocDec + sigD (DocName name) (DocType type_) = DocDec $ name PP.<+> PP.text "::" PP.<+> type_ noPrec + + funD :: DocName -> [DocClause] -> DocDec + funD (DocName name) cls = DocDec $ foldr1 (PP.$+$) [name PP.<+> cl | DocClause cl <- cls] + + +fromTextDetails :: PP.TextDetails -> ShowS +fromTextDetails td = + case td of + PP.Chr c -> (c:) + PP.Str str -> (str++) + PP.PStr str -> (str++) + +renderDocDec :: DocDec -> ShowS +renderDocDec (DocDec dec) = showString $ PP.render dec + +renderDocDecs :: [[DocDec]] -> ShowS +renderDocDecs dss = + PP.fullRender PP.PageMode 80 1.5 (\td s -> fromTextDetails td . s) id d + where + d = PP.vcat (map renderGroup dss) + renderGroup ds = PP.vcat [ d1 | DocDec d1 <- ds ] PP.$+$ PP.text "" + +parensIf :: Bool -> PP.Doc -> PP.Doc +parensIf True = PP.parens +parensIf False = id \ No newline at end of file From 335411c789f7785b478522082661ef6e927f2f35 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Mon, 14 Mar 2022 16:28:59 +0300 Subject: [PATCH 07/39] Code refactoring --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 116 +++++----- .../src/Happy/Backend/CodeCombinators.hs | 58 ++--- .../Happy/Backend/CodeCombinators/Syntax.hs | 214 ++++++++++-------- 3 files changed, 209 insertions(+), 179 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index ddc43698..0500aa4e 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -593,11 +593,10 @@ machinery to discard states in the parser... > sigD happy_n_nonterms_name (conT $ mkName "Prelude.Int"), > funD happy_n_nonterms_name [clause [] (intE n_nonterminals) []] > ] -> ] +> ] > . nl > where happy_n_terms_name = mkName "happy_n_terms" > happy_n_nonterms_name = mkName "happy_n_nonterms_name" - % {-# NOINLINE happyExpListPerState #-} % happyExpListPerState st = token_strs_expected @@ -614,25 +613,27 @@ machinery to discard states in the parser... > produceExpListPerState > = produceExpListArray > . str "{-# NOINLINE happyExpListPerState #-}\n" -> . (renderDocDec happy_exp_list_per_state_dec) +> . renderDocDecs [[happy_exp_list_per_state_dec]] > . nl > where (first_token, last_token) = bounds token_names' > nr_tokens = last_token - first_token + 1 -> -> --happyExpListPerState st = token_strs_expected +> +> --happyExpListPerState st = token_strs_expected > happy_exp_list_per_state_name = mkName "happyExpListPerState" -> happy_exp_list_per_state_dec = funD happy_exp_list_per_state_name [clause [st_pat] (varE token_strs_expected_name) -> [ -> token_strs_dec, -> bit_start_dec, -> bit_end_dec, -> read_bit_dec, -> bits_dec, -> bits_indexed_dec, -> f_dec, -> token_strs_expected_dec -> ] -> ] :: DocDec +> happy_exp_list_per_state_dec = +> funD happy_exp_list_per_state_name [ +> clause [st_pat] (varE token_strs_expected_name) [ +> token_strs_dec, +> bit_start_dec, +> bit_end_dec, +> read_bit_dec, +> bits_dec, +> bits_indexed_dec, +> f_dec, +> token_strs_expected_dec +> ] +> ] :: DocDec +> > st_name = mkName "st" > st_var = varE st_name > st_pat = varP st_name @@ -642,44 +643,48 @@ machinery to discard states in the parser... > > --token_strs = elems token_names' > token_strs_name = mkName "token_strs" -> token_strs_dec = funD token_strs_name [clause [] token_strs_exp []] :: DocDec +> token_strs_dec = funD token_strs_name [clause [] token_strs_exp []] > where token_strs_exp = listE [stringE str_elem | str_elem <- elems token_names'] > -> --bit_start = st Prelude.* nr_tokens +> --bit_start = st Prelude.* nr_tokens > bit_start_name = mkName "bit_start" -> bit_start_dec = funD bit_start_name [clause [] bit_start_exp []] :: DocDec +> bit_start_dec = funD bit_start_name [clause [] bit_start_exp []] > where bit_start_exp = appE (appE mulE st_var) (intE nr_tokens) -> +> > --bit_end = (st Prelude.+ 1) Prelude.* nr_tokens > bit_end_name = mkName "bit_end" -> bit_end_dec = funD bit_end_name [clause [] bit_end_exp []] :: DocDec +> bit_end_dec = funD bit_end_name [clause [] bit_end_exp []] > where bit_end_exp = appE (appE mulE (appE (appE addE st_var) (intE 1))) (intE nr_tokens) -> +> > --read_bit = readArrayBit happyExpList > read_bit_name = mkName "read_bit" -> read_bit_dec = funD read_bit_name [clause [] read_bit_exp []] :: DocDec +> read_bit_dec = funD read_bit_name [clause [] read_bit_exp []] > where read_bit_exp = appE (varE $ mkName "readArrayBit") (varE $ mkName "happyExpList") > > --bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] > bits_name = mkName "bits" -> bits_dec = funD bits_name [clause [] bits_exp []] :: DocDec -> where bits_exp = appE ( -> appE (varE $ mkName "Prelude.map") -> (varE $ mkName "read_bit") -> ) -> ( -> arithSeqE ( -> FromToR -> (varE bit_start_name) -> (appE (appE subE (varE bit_end_name)) (intE 1))) -> ) +> bits_dec = funD bits_name [clause [] bits_exp []] +> where bits_exp = +> appE ( +> appE (varE $ mkName "Prelude.map") +> (varE $ mkName "read_bit") +> ) +> ( +> arithSeqE ( +> FromToR +> (varE bit_start_name) +> (appE (appE subE (varE bit_end_name)) (intE 1)) +> ) +> ) +> > --bits_indexed = Prelude.zip bits [0... nr_tokens - 1] > bits_indexed_name = mkName "bits_indexed" -> bits_indexed_dec = funD bits_indexed_name [clause [] bits_indexed_exp []] :: DocDec -> where bits_indexed_exp = appE -> (appE (varE $ mkName "Prelude.zip") (varE bits_name)) -> (arithSeqE $ FromToR (intE 0) (intE $ nr_tokens - 1)) -> +> bits_indexed_dec = funD bits_indexed_name [clause [] bits_indexed_exp []] +> where bits_indexed_exp = +> appE +> (appE (varE $ mkName "Prelude.zip") (varE bits_name)) +> (arithSeqE $ FromToR (intE 0) (intE $ nr_tokens - 1)) +> > --f (Prelude.False, _) = []\n" > --f (Prelude.True, nr) = [token_strs Prelude.!! nr]\n > f_name = mkName "f" @@ -687,21 +692,26 @@ machinery to discard states in the parser... > where clause1 = clause [tupP [conP (mkName "Prelude.False") [], wildP]] (conE $ mkName "[]") [] > clause2 = clause [tupP [conP (mkName "Prelude.True") [], varP nr]] exp2 [] > nr = mkName "nr" -> exp2 = listE [ -> appE ( -> appE (varE $ mkName "(Prelude.!!)") -> (varE token_strs_name) -> ) -> (varE nr) -> ] +> exp2 = +> listE [ +> appE ( +> appE +> (varE $ mkName "(Prelude.!!)") +> (varE token_strs_name) +> ) +> (varE nr) +> ] +> > --token_strs_expected = Prelude.concatMap f token_strs_name = mkName "token_strs" > token_strs_expected_name = mkName "token_strs_expected" -> token_strs_expected_dec = funD token_strs_expected_name [clause [] token_strs_expected_exp []] :: DocDec -> where token_strs_expected_exp = appE ( -> appE (varE $ mkName "Prelude.concatMap") -> (varE f_name) -> ) -> (varE bits_indexed_name) +> token_strs_expected_dec = funD token_strs_expected_name [clause [] token_strs_expected_exp []] +> where token_strs_expected_exp = +> appE ( +> appE +> (varE $ mkName "Prelude.concatMap") +> (varE f_name) +> ) +> (varE bits_indexed_name) > produceStateFunction goto' (state, acts) > = foldr (.) id (map produceActions assocs_acts) > . foldr (.) id (map produceGotos (assocs gotos)) diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 5e0d8cbd..1d289fbb 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -1,38 +1,38 @@ -module Happy.Backend.CodeCombinators where - +module Happy.Backend.CodeCombinators where + import qualified Language.Haskell.TH as TH -class CodeGen e where - type NameT e = n | n -> e - type RangeT e = r | r -> e - type TypeT e = t | t -> e - type PatT e = p | p -> e - type DecT e = d | d -> e - type ClauseT e = c | c -> e +class CodeGen e where + type NameT e = n | n -> e + type RangeT e = r | r -> e + type TypeT e = t | t -> e + type PatT e = p | p -> e + type DecT e = d | d -> e + type ClauseT e = c | c -> e - mkName :: String -> NameT e - intE :: Int -> e - stringE :: String -> e + mkName :: String -> NameT e + intE :: Int -> e + stringE :: String -> e - conE :: NameT e -> e - varE :: NameT e -> e - appE :: e -> e -> e + conE :: NameT e -> e + varE :: NameT e -> e + appE :: e -> e -> e - tupE :: [e] -> e - listE :: [e] -> e - arithSeqE :: RangeT e -> e + tupE :: [e] -> e + listE :: [e] -> e + arithSeqE :: RangeT e -> e - conT :: NameT e -> TypeT e - varT :: NameT e -> TypeT e - appT :: TypeT e -> TypeT e -> TypeT e + conT :: NameT e -> TypeT e + varT :: NameT e -> TypeT e + appT :: TypeT e -> TypeT e -> TypeT e - litP :: TH.Lit -> PatT e - varP :: NameT e -> PatT e - tupP :: [PatT e] -> PatT e - conP :: NameT e -> [PatT e] -> PatT e - wildP :: PatT e + litP :: TH.Lit -> PatT e + varP :: NameT e -> PatT e + tupP :: [PatT e] -> PatT e + conP :: NameT e -> [PatT e] -> PatT e + wildP :: PatT e - clause :: [PatT e] -> e -> [DecT e] -> ClauseT e + clause :: [PatT e] -> e -> [DecT e] -> ClauseT e - sigD :: NameT e -> TypeT e -> DecT e - funD :: NameT e -> [ClauseT e] -> DecT e + sigD :: NameT e -> TypeT e -> DecT e + funD :: NameT e -> [ClauseT e] -> DecT e diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index 3c399f20..00140848 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -10,106 +10,126 @@ newtype Prec = Prec Int atomPrec, appPrec, noPrec :: Prec atomPrec = Prec maxBound -appPrec = Prec 10 -noPrec = Prec (-1) +appPrec = Prec 10 +noPrec = Prec (-1) -newtype DocExp = DocExp (Prec -> PP.Doc) -newtype DocType = DocType (Prec -> PP.Doc) -newtype DocPat = DocPat (Prec -> PP.Doc) +newtype DocExp = DocExp (Prec -> PP.Doc) +newtype DocType = DocType (Prec -> PP.Doc) +newtype DocPat = DocPat (Prec -> PP.Doc) -newtype DocName = DocName PP.Doc - deriving (Eq, Show) +newtype DocName = DocName PP.Doc + deriving (Eq, Show) newtype DocClause = DocClause PP.Doc - deriving (Eq, Show) -newtype DocDec = DocDec PP.Doc - deriving (Eq, Show) + deriving (Eq, Show) +newtype DocDec = DocDec PP.Doc + deriving (Eq, Show) -data DocRange = FromR DocExp - | FromThenR DocExp DocExp - | FromToR DocExp DocExp - | FromThenToR DocExp DocExp DocExp +data DocRange + = FromR DocExp + | FromThenR DocExp DocExp + | FromToR DocExp DocExp + | FromThenToR DocExp DocExp DocExp instance CodeGen DocExp where - type NameT DocExp = DocName - type RangeT DocExp = DocRange - type TypeT DocExp = DocType - type PatT DocExp = DocPat - type DecT DocExp = DocDec - type ClauseT DocExp = DocClause - - mkName :: String -> DocName - mkName name = DocName $ PP.text name - - intE :: Int -> DocExp - intE num = DocExp (\_ -> parensIf (num < 0) (PP.int num)) - - stringE :: String -> DocExp - stringE str = DocExp (\_ -> PP.doubleQuotes $ PP.text str) - - conE :: DocName -> DocExp - conE (DocName name) = DocExp $ \_ -> name - - varE :: DocName -> DocExp - varE (DocName name) = DocExp $ \_ -> name - - appE :: DocExp -> DocExp -> DocExp - appE (DocExp e1) (DocExp e2) = DocExp $ \p -> parensIf (p > appPrec) $ - PP.sep [e1 appPrec, e2 atomPrec] - - - tupE :: [DocExp] -> DocExp - tupE ds = DocExp $ \_ -> PP.parens $ PP.sep $ PP.punctuate PP.comma $ - [d noPrec | DocExp d <- ds] - - listE :: [DocExp] -> DocExp - listE ds = DocExp $ \_ -> PP.brackets $ PP.sep $ PP.punctuate PP.comma $ - [d noPrec | DocExp d <- ds] - - arithSeqE :: DocRange -> DocExp - arithSeqE (FromToR (DocExp e1) (DocExp e2)) = DocExp $ \_ -> PP.brackets $ e1 noPrec <> PP.text ".." <> e2 noPrec - - conT :: DocName -> DocType - conT (DocName name) = DocType $ \_ -> name - - varT :: DocName -> DocType - varT (DocName name) = DocType $ \_ -> name - - appT :: DocType -> DocType -> DocType - appT (DocType t1) (DocType t2) = DocType $ \p -> parensIf (p > appPrec) $ - PP.sep [t1 appPrec, t2 atomPrec] - - litP :: TH.Lit -> DocPat - litP (TH.CharL c) = DocPat $ \_ -> PP.quotes $ PP.text [c] - litP (TH.StringL s) = DocPat $ \_ -> PP.doubleQuotes $ PP.text s - litP (TH.IntegerL n) = DocPat $ \_ -> parensIf (n < 0) $ PP.text $ show n - - varP :: DocName -> DocPat - varP (DocName name) = DocPat $ \_ -> name - - tupP :: [DocPat] -> DocPat - tupP ps = DocPat $ \_ -> - PP.parens $ PP.sep $ PP.punctuate PP.comma [p noPrec | DocPat p <- ps] - - conP :: DocName -> [DocPat] -> DocPat - conP (DocName name) ps = DocPat $ \p -> parensIf (p > appPrec) $ - name PP.<+> PP.sep [p atomPrec | DocPat p <- ps] - wildP :: DocPat - wildP = DocPat $ \_ -> PP.text "_" - - clause :: [DocPat] -> DocExp -> [DocDec] -> DocClause - clause ps (DocExp exp) decs = DocClause $ (PP.sep [p noPrec | DocPat p <- ps] PP.<+> - PP.text "=" PP.<+> exp noPrec) PP.$+$ PP.nest 4 whereSection - where whereSection = case decs of - [] -> PP.empty - _ -> PP.text "where" PP.$+$ - foldr (PP.$+$) PP.empty [PP.nest 4 dec | DocDec dec <- decs] - - sigD :: DocName -> DocType -> DocDec - sigD (DocName name) (DocType type_) = DocDec $ name PP.<+> PP.text "::" PP.<+> type_ noPrec - - funD :: DocName -> [DocClause] -> DocDec - funD (DocName name) cls = DocDec $ foldr1 (PP.$+$) [name PP.<+> cl | DocClause cl <- cls] + type NameT DocExp = DocName + type RangeT DocExp = DocRange + type TypeT DocExp = DocType + type PatT DocExp = DocPat + type DecT DocExp = DocDec + type ClauseT DocExp = DocClause + + mkName :: String -> DocName + mkName name = DocName $ PP.text name + + intE :: Int -> DocExp + intE num = DocExp (\_ -> parensIf (num < 0) (PP.int num)) + + stringE :: String -> DocExp + stringE str = DocExp (\_ -> PP.doubleQuotes $ PP.text str) + + conE :: DocName -> DocExp + conE (DocName name) = DocExp $ \_ -> name + + varE :: DocName -> DocExp + varE (DocName name) = DocExp $ \_ -> name + + appE :: DocExp -> DocExp -> DocExp + appE (DocExp e1) (DocExp e2) = + DocExp $ \p -> + parensIf (p > appPrec) $ + PP.sep [e1 appPrec, e2 atomPrec] + + + tupE :: [DocExp] -> DocExp + tupE ds = + DocExp $ \_ -> + PP.parens $ PP.sep $ PP.punctuate PP.comma $ + [d noPrec | DocExp d <- ds] + + listE :: [DocExp] -> DocExp + listE ds = + DocExp $ \_ -> + PP.brackets $ PP.sep $ PP.punctuate PP.comma $ + [d noPrec | DocExp d <- ds] + + arithSeqE :: DocRange -> DocExp + arithSeqE (FromToR (DocExp e1) (DocExp e2)) = + DocExp $ \_ -> + PP.brackets $ e1 noPrec <> PP.text ".." <> e2 noPrec + + conT :: DocName -> DocType + conT (DocName name) = DocType $ \_ -> name + + varT :: DocName -> DocType + varT (DocName name) = DocType $ \_ -> name + + appT :: DocType -> DocType -> DocType + appT (DocType t1) (DocType t2) = + DocType $ \p -> + parensIf (p > appPrec) $ + PP.sep [t1 appPrec, t2 atomPrec] + + litP :: TH.Lit -> DocPat + litP (TH.CharL c) = DocPat $ \_ -> PP.quotes $ PP.text [c] + litP (TH.StringL s) = DocPat $ \_ -> PP.doubleQuotes $ PP.text s + litP (TH.IntegerL n) = DocPat $ \_ -> parensIf (n < 0) $ PP.text $ show n + + varP :: DocName -> DocPat + varP (DocName name) = DocPat $ \_ -> name + + tupP :: [DocPat] -> DocPat + tupP ps = + DocPat $ \_ -> + PP.parens $ PP.sep $ + PP.punctuate PP.comma [p noPrec | DocPat p <- ps] + + conP :: DocName -> [DocPat] -> DocPat + conP (DocName name) ps = + DocPat $ \p -> + parensIf (p > appPrec) $ + name PP.<+> PP.sep [pt atomPrec | DocPat pt <- ps] + + wildP :: DocPat + wildP = DocPat $ \_ -> PP.text "_" + + clause :: [DocPat] -> DocExp -> [DocDec] -> DocClause + clause ps (DocExp exp) decs = + DocClause $ + (PP.sep [p noPrec | DocPat p <- ps] PP.<+> PP.text "=" PP.<+> exp noPrec) + PP.$+$ PP.nest 4 whereSection + where whereSection = + case decs of + [] -> PP.empty + _ -> + PP.text "where" PP.$+$ + foldr (PP.$+$) PP.empty [PP.nest 4 dec | DocDec dec <- decs] + + sigD :: DocName -> DocType -> DocDec + sigD (DocName name) (DocType type_) = DocDec $ name PP.<+> PP.text "::" PP.<+> type_ noPrec + + funD :: DocName -> [DocClause] -> DocDec + funD (DocName name) cls = DocDec $ foldr1 (PP.$+$) [name PP.<+> cl | DocClause cl <- cls] fromTextDetails :: PP.TextDetails -> ShowS @@ -119,16 +139,16 @@ fromTextDetails td = PP.Str str -> (str++) PP.PStr str -> (str++) -renderDocDec :: DocDec -> ShowS -renderDocDec (DocDec dec) = showString $ PP.render dec +renderDocDec :: DocDec -> ShowS +renderDocDec (DocDec dec) = showString $ PP.render dec renderDocDecs :: [[DocDec]] -> ShowS renderDocDecs dss = - PP.fullRender PP.PageMode 80 1.5 (\td s -> fromTextDetails td . s) id d + PP.fullRender PP.PageMode 120 1.5 (\td s -> fromTextDetails td . s) id d where d = PP.vcat (map renderGroup dss) renderGroup ds = PP.vcat [ d1 | DocDec d1 <- ds ] PP.$+$ PP.text "" parensIf :: Bool -> PP.Doc -> PP.Doc parensIf True = PP.parens -parensIf False = id \ No newline at end of file +parensIf False = id From 36a9c37bb4e4a8fa42fe2697fe0b78b6c82fd217 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Mon, 14 Mar 2022 16:52:57 +0300 Subject: [PATCH 08/39] Add some useful combinators --- .../src/Happy/Backend/CodeCombinators.hs | 32 +++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 1d289fbb..e10fcb7a 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -36,3 +36,35 @@ class CodeGen e where sigD :: NameT e -> TypeT e -> DecT e funD :: NameT e -> [ClauseT e] -> DecT e + + + +trueE :: CodeGen e => e +trueE = conE $ mkName "Prelude.True" + +falseE :: CodeGen e => e +falseE = conE $ mkName "Prelude.False" + +trueP :: CodeGen e => PatT e +trueP = conP (mkName "Prelude.True") [] + +falseP :: CodeGen e => PatT e +falseP = conP (mkName "Prelude.False") [] + +mulE :: CodeGen e => e +mulE = varE $ mkName "(Prelude.*)" + +addE :: CodeGen e => e +addE = varE $ mkName "(Prelude.+)" + +subE :: CodeGen e => e +subE = varE $ mkName "(Prelude.-)" + +intT :: CodeGen e => TypeT e +intT = conT $ mkName "Prelude.Int" + +emptyListE :: CodeGen e => e +emptyListE = conE $ mkName "[]" + +emptyListP :: CodeGen e => PatT e +emptyListP = conP (mkName "[]") [] From ac400e85015c44b5ca5794c1ecac18d61c49c536 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Mon, 14 Mar 2022 17:18:43 +0300 Subject: [PATCH 09/39] Rewrite some code in ProduceCode.lhs using simple combinators from previous commit --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 0500aa4e..a6750bc5 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -586,11 +586,11 @@ machinery to discard states in the parser... > . produceReduceArray > . renderDocDecs [ > [ -> sigD happy_n_terms_name (conT $ mkName "Prelude.Int"), +> sigD happy_n_terms_name intT, > funD happy_n_terms_name [clause [] (intE n_terminals) []] > ], > [ -> sigD happy_n_nonterms_name (conT $ mkName "Prelude.Int"), +> sigD happy_n_nonterms_name intT, > funD happy_n_nonterms_name [clause [] (intE n_nonterminals) []] > ] > ] @@ -632,14 +632,11 @@ machinery to discard states in the parser... > f_dec, > token_strs_expected_dec > ] -> ] :: DocDec +> ] > > st_name = mkName "st" > st_var = varE st_name > st_pat = varP st_name -> mulE = varE $ mkName "(Prelude.*)" -> addE = varE $ mkName "(Prelude.+)" -> subE = varE $ mkName "(Prelude.-)" > > --token_strs = elems token_names' > token_strs_name = mkName "token_strs" @@ -689,8 +686,8 @@ machinery to discard states in the parser... > --f (Prelude.True, nr) = [token_strs Prelude.!! nr]\n > f_name = mkName "f" > f_dec = funD f_name [clause1, clause2] -> where clause1 = clause [tupP [conP (mkName "Prelude.False") [], wildP]] (conE $ mkName "[]") [] -> clause2 = clause [tupP [conP (mkName "Prelude.True") [], varP nr]] exp2 [] +> where clause1 = clause [tupP [falseP, wildP]] emptyListE [] +> clause2 = clause [tupP [trueP, varP nr]] exp2 [] > nr = mkName "nr" > exp2 = > listE [ From c3feb99cf3ff3000149f5ed71ce654bddedd9443 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Mon, 14 Mar 2022 22:31:30 +0300 Subject: [PATCH 10/39] Add mkOpName in CodeGen class (because of parens for op name in DocExp case) --- .../code-combinators/src/Happy/Backend/CodeCombinators.hs | 7 ++++--- .../src/Happy/Backend/CodeCombinators/Syntax.hs | 3 +++ 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index e10fcb7a..73553ad4 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -11,6 +11,7 @@ class CodeGen e where type ClauseT e = c | c -> e mkName :: String -> NameT e + mkOpName :: String -> NameT e intE :: Int -> e stringE :: String -> e @@ -52,13 +53,13 @@ falseP :: CodeGen e => PatT e falseP = conP (mkName "Prelude.False") [] mulE :: CodeGen e => e -mulE = varE $ mkName "(Prelude.*)" +mulE = varE $ mkOpName "Prelude.*" addE :: CodeGen e => e -addE = varE $ mkName "(Prelude.+)" +addE = varE $ mkOpName "Prelude.+" subE :: CodeGen e => e -subE = varE $ mkName "(Prelude.-)" +subE = varE $ mkOpName "Prelude.-" intT :: CodeGen e => TypeT e intT = conT $ mkName "Prelude.Int" diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index 00140848..c75cedf4 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -42,6 +42,9 @@ instance CodeGen DocExp where mkName :: String -> DocName mkName name = DocName $ PP.text name + mkOpName :: String -> DocName + mkOpName name = DocName $ PP.parens $ PP.text name + intE :: Int -> DocExp intE num = DocExp (\_ -> parensIf (num < 0) (PP.int num)) From 67dbf3c1af02e9598ab94bc76177ad928fac562f Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Mon, 14 Mar 2022 23:09:04 +0300 Subject: [PATCH 11/39] Add instance CodeGen TH.Exp --- .../happy-code-combinators.cabal | 3 +- .../Happy/Backend/CodeCombinators/Abstract.hs | 78 +++++++++++++++++++ 2 files changed, 80 insertions(+), 1 deletion(-) create mode 100644 packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index 6f7792b7..39bbf308 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -38,7 +38,8 @@ library hs-source-dirs: src exposed-modules: Happy.Backend.CodeCombinators, - Happy.Backend.CodeCombinators.Syntax + Happy.Backend.CodeCombinators.Syntax, + Happy.Backend.CodeCombinators.Abstract build-depends: base < 5, array, diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs new file mode 100644 index 00000000..de8f5658 --- /dev/null +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs @@ -0,0 +1,78 @@ +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Happy.Backend.CodeCombinators.Abstract where + +import Happy.Backend.CodeCombinators +import qualified Language.Haskell.TH as TH + +instance CodeGen TH.Exp where + type NameT TH.Exp = TH.Name + type RangeT TH.Exp = TH.Range + type TypeT TH.Exp = TH.Type + type PatT TH.Exp = TH.Pat + type DecT TH.Exp = TH.Dec + type ClauseT TH.Exp = TH.Clause + + mkName :: String -> TH.Name + mkName = TH.mkName + + mkOpName :: String -> TH.Name + mkOpName = TH.mkName + + intE :: Int -> TH.Exp + intE num = TH.LitE $ TH.IntegerL $ fromIntegral num + + stringE :: String -> TH.Exp + stringE str = TH.LitE $ TH.StringL str + + conE :: TH.Name -> TH.Exp + conE = TH.ConE + + varE :: TH.Name -> TH.Exp + varE = TH.VarE + + appE :: TH.Exp -> TH.Exp -> TH.Exp + appE = TH.AppE + + + tupE :: [TH.Exp] -> TH.Exp + tupE es = TH.TupE $ map Just es + + listE :: [TH.Exp] -> TH.Exp + listE = TH.ListE + + arithSeqE :: TH.Range -> TH.Exp + arithSeqE = TH.ArithSeqE + + conT :: TH.Name -> TH.Type + conT = TH.ConT + + varT :: TH.Name -> TH.Type + varT = TH.VarT + + appT :: TH.Type -> TH.Type -> TH.Type + appT = TH.AppT + + litP :: TH.Lit -> TH.Pat + litP = TH.LitP + + varP :: TH.Name -> TH.Pat + varP = TH.VarP + + tupP :: [TH.Pat] -> TH.Pat + tupP = TH.TupP + + conP :: TH.Name -> [TH.Pat] -> TH.Pat + conP = TH.ConP + + wildP :: TH.Pat + wildP = TH.WildP + + clause :: [TH.Pat] -> TH.Exp -> [TH.Dec] -> TH.Clause + clause ps e decs = TH.Clause ps (TH.NormalB e) decs + + sigD :: TH.Name -> TH.Type -> TH.Dec + sigD = TH.SigD + + funD :: TH.Name -> [TH.Clause] -> TH.Dec + funD = TH.FunD From a69eac4b0e8b97e1bd5dc3926e3eea874b1aaa7b Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 15 Mar 2022 23:22:16 +0300 Subject: [PATCH 12/39] Add monad to CodeGen class for newNames generating --- .../happy-code-combinators.cabal | 13 +++++++++--- .../src/Happy/Backend/CodeCombinators.hs | 20 +++++++++++++++++-- .../Happy/Backend/CodeCombinators/Abstract.hs | 4 ++++ .../Happy/Backend/CodeCombinators/Syntax.hs | 5 +++++ 4 files changed, 37 insertions(+), 5 deletions(-) diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index 39bbf308..727d98a8 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -44,9 +44,16 @@ library build-depends: base < 5, array, pretty, - template-haskell + template-haskell, + mtl, + containers default-language: Haskell98 - default-extensions: CPP, MagicHash, InstanceSigs, TypeFamilyDependencies + default-extensions: CPP, + MagicHash, + InstanceSigs, + TypeFamilyDependencies, + KindSignatures, + FlexibleContexts + ghc-options: -Wall --- other-modules: Paths_happy_backend_lalr diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 73553ad4..940e3514 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} module Happy.Backend.CodeCombinators where import qualified Language.Haskell.TH as TH +import Control.Monad.State +import qualified Data.Map as Map +import Data.Kind (Type) class CodeGen e where type NameT e = n | n -> e @@ -9,9 +14,12 @@ class CodeGen e where type PatT e = p | p -> e type DecT e = d | d -> e type ClauseT e = c | c -> e + type NewNameM e :: Type -> Type mkName :: String -> NameT e mkOpName :: String -> NameT e + newName :: String -> NewNameM e (NameT e) + intE :: Int -> e stringE :: String -> e @@ -38,8 +46,6 @@ class CodeGen e where sigD :: NameT e -> TypeT e -> DecT e funD :: NameT e -> [ClauseT e] -> DecT e - - trueE :: CodeGen e => e trueE = conE $ mkName "Prelude.True" @@ -69,3 +75,13 @@ emptyListE = conE $ mkName "[]" emptyListP :: CodeGen e => PatT e emptyListP = conP (mkName "[]") [] + +type NameContext e r = StateT (Map.Map String (NameT e)) (NewNameM e) r + +createName :: (CodeGen e, Monad (NewNameM e)) => String -> NameContext e () +createName name = do + newName_ <- lift $ newName name + modify $ \treeMap -> Map.insert name newName_ treeMap + +getName :: (CodeGen e, Monad (NewNameM e)) => String -> NameContext e (NameT e) +getName name = gets (Map.! name) diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs index de8f5658..ccb91fb5 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs @@ -12,6 +12,7 @@ instance CodeGen TH.Exp where type PatT TH.Exp = TH.Pat type DecT TH.Exp = TH.Dec type ClauseT TH.Exp = TH.Clause + type NewNameM TH.Exp = TH.Q mkName :: String -> TH.Name mkName = TH.mkName @@ -19,6 +20,9 @@ instance CodeGen TH.Exp where mkOpName :: String -> TH.Name mkOpName = TH.mkName + newName :: String -> TH.Q TH.Name + newName = TH.newName + intE :: Int -> TH.Exp intE num = TH.LitE $ TH.IntegerL $ fromIntegral num diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index c75cedf4..20fd7a21 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -3,6 +3,7 @@ module Happy.Backend.CodeCombinators.Syntax where import Happy.Backend.CodeCombinators import qualified Text.PrettyPrint as PP import qualified Language.Haskell.TH as TH +import Control.Monad.Identity (Identity) newtype Prec = Prec Int @@ -38,6 +39,7 @@ instance CodeGen DocExp where type PatT DocExp = DocPat type DecT DocExp = DocDec type ClauseT DocExp = DocClause + type NewNameM DocExp = Identity mkName :: String -> DocName mkName name = DocName $ PP.text name @@ -45,6 +47,9 @@ instance CodeGen DocExp where mkOpName :: String -> DocName mkOpName name = DocName $ PP.parens $ PP.text name + newName :: String -> Identity DocName + newName = return . mkName + intE :: Int -> DocExp intE num = DocExp (\_ -> parensIf (num < 0) (PP.int num)) From f59ce786026ef88b1eb852adcdfa98d2cbe81f83 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Mon, 21 Mar 2022 16:51:07 +0300 Subject: [PATCH 13/39] Add hedgehog tests for DocExp generating --- .../happy-code-combinators.cabal | 25 ++++ .../src/Happy/Backend/CodeCombinators.hs | 1 + .../Happy/Backend/CodeCombinators/Abstract.hs | 10 +- .../Happy/Backend/CodeCombinators/Syntax.hs | 35 ++++- packages/code-combinators/test/Test.hs | 20 +++ .../test/Test/CodeCombinators/GenExp.hs | 136 ++++++++++++++++++ 6 files changed, 223 insertions(+), 4 deletions(-) create mode 100644 packages/code-combinators/test/Test.hs create mode 100644 packages/code-combinators/test/Test/CodeCombinators/GenExp.hs diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index 727d98a8..6ab3122a 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -57,3 +57,28 @@ library FlexibleContexts ghc-options: -Wall + + +test-suite test + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: + Test.CodeCombinators.GenExp + + hs-source-dirs: + test + + default-extensions: + OverloadedStrings + , TemplateHaskell + + ghc-options: -Wall + build-depends: + HUnit + , base < 5 + , hedgehog + , template-haskell + , happy-code-combinators + , haskell-src-meta + + default-language: Haskell98 diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 940e3514..2b3a0b71 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -21,6 +21,7 @@ class CodeGen e where newName :: String -> NewNameM e (NameT e) intE :: Int -> e + negateE :: e -> e stringE :: String -> e conE :: NameT e -> e diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs index ccb91fb5..6c4cfade 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs @@ -23,8 +23,16 @@ instance CodeGen TH.Exp where newName :: String -> TH.Q TH.Name newName = TH.newName + negateE :: TH.Exp -> TH.Exp + negateE = TH.AppE (TH.VarE $ mkName "GHC.Num.negate") + intE :: Int -> TH.Exp - intE num = TH.LitE $ TH.IntegerL $ fromIntegral num + intE num + | num < 0 = negateE absE + | otherwise = absE + where absE = + TH.LitE $ TH.IntegerL $ + fromIntegral $ abs num stringE :: String -> TH.Exp stringE str = TH.LitE $ TH.StringL str diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index 20fd7a21..3946361e 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -1,4 +1,16 @@ -module Happy.Backend.CodeCombinators.Syntax where +module Happy.Backend.CodeCombinators.Syntax + ( + DocExp(..), + DocName(..), + DocClause(..), + DocDec(..), + DocRange(..), + CodeGen(..), + renderDocDecs, + renderDocDec, + render + ) + where import Happy.Backend.CodeCombinators import qualified Text.PrettyPrint as PP @@ -50,11 +62,24 @@ instance CodeGen DocExp where newName :: String -> Identity DocName newName = return . mkName + negateE :: DocExp -> DocExp + negateE = appE $ varE $ mkName "GHC.Num.negate" + intE :: Int -> DocExp - intE num = DocExp (\_ -> parensIf (num < 0) (PP.int num)) + intE num + | num < 0 = negateE absE + | otherwise = absE + where absE = + DocExp $ \_ -> + PP.int $ abs num stringE :: String -> DocExp - stringE str = DocExp (\_ -> PP.doubleQuotes $ PP.text str) + stringE str = DocExp (\_ -> PP.doubleQuotes $ PP.text $ escape str) + where escape ('\'':xs) = '\\' : '\'' : escape xs + escape ('\"':xs) = '\\' : '\"' : escape xs + escape ('\\':xs) = '\\' : '\\' : escape xs + escape (x:xs) = x : escape xs + escape [] = [] conE :: DocName -> DocExp conE (DocName name) = DocExp $ \_ -> name @@ -147,6 +172,10 @@ fromTextDetails td = PP.Str str -> (str++) PP.PStr str -> (str++) +render :: DocExp -> ShowS +render (DocExp exp) = showString $ PP.render $ exp noPrec + + renderDocDec :: DocDec -> ShowS renderDocDec (DocDec dec) = showString $ PP.render dec diff --git a/packages/code-combinators/test/Test.hs b/packages/code-combinators/test/Test.hs new file mode 100644 index 00000000..c1c05a21 --- /dev/null +++ b/packages/code-combinators/test/Test.hs @@ -0,0 +1,20 @@ +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Language.Haskell.TH as TH +import Test.CodeCombinators.GenExp +import Language.Haskell.Meta.Parse +import Data.Either + +prop_exp :: Property +prop_exp = + property $ do + exp <- forAll genExp + let parse_result = parseExp (expToString exp) + assert $ isRight parse_result + let Right result = parse_result + exp === deleteParensE result + +main :: IO Bool +main = checkParallel $$(discover) + diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs new file mode 100644 index 00000000..7d5c838b --- /dev/null +++ b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs @@ -0,0 +1,136 @@ +module Test.CodeCombinators.GenExp where + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Language.Haskell.TH as TH +import qualified Happy.Backend.CodeCombinators.Syntax as SnGen +import qualified Happy.Backend.CodeCombinators.Abstract as AbsGen +import Happy.Backend.CodeCombinators +import Data.List +import Data.Maybe + + +genFunName :: MonadGen m => m TH.Name +genFunName = do + name_tail <- Gen.list (Range.linear 1 10) Gen.alphaNum + name_head <- Gen.lower + return $ mkName $ (name_head : name_tail) ++ "_" + +genClassName :: MonadGen m => m TH.Name +genClassName = do + name_tail <- Gen.list (Range.linear 1 10) Gen.alphaNum + name_head <- Gen.upper + return $ mkName $ (name_head : name_tail) ++ "_" + +genIntE :: MonadGen m => m TH.Exp +genIntE = do + x <- Gen.int $ Range.linear minBound maxBound + return $ intE x + +genStringE :: MonadGen m => m TH.Exp +genStringE = do + str <- Gen.list (Range.linear 0 20) Gen.latin1 + return $ stringE $ delete '\n' str + +genConE :: MonadGen m => m TH.Exp +genConE = do + conName <- genClassName + return $ TH.ConE conName + +genVarE :: MonadGen m => m TH.Exp +genVarE = do + varName <- genFunName + return $ TH.VarE varName + +genAppE :: MonadGen m => m TH.Exp +genAppE = do + e1 <- genExp + e2 <- genExp + return $ appE e1 e2 + +genTupE :: MonadGen m => m TH.Exp +genTupE = do + es <- Gen.list (Range.linear 2 20) genExp + return $ tupE es + +genListE :: MonadGen m => m TH.Exp +genListE = do + es <- Gen.list (Range.linear 1 20) genExp + return $ listE es + +genExp :: MonadGen m => m TH.Exp +genExp = + Gen.recursive Gen.choice + [ + genIntE, + genStringE, + genConE, + genVarE + ] + [ + genAppE, + genTupE, + genListE + ] + + +fullName :: TH.Name -> String +fullName nm = + moduleName ++ TH.nameBase nm + where moduleName = + case TH.nameModule nm of + Just str -> str ++ "." + Nothing -> "" + +expToString :: TH.Exp -> String +expToString e = SnGen.render (expToDocExp e) "" + +expToDocExp :: TH.Exp -> SnGen.DocExp +expToDocExp (TH.LitE l) = + case l of + TH.StringL str -> SnGen.stringE str + TH.IntegerL num -> SnGen.intE (fromIntegral num) + _ -> error "invalid literal" + +expToDocExp (TH.ConE nm) = + SnGen.conE $ SnGen.mkName $ fullName nm + +expToDocExp (TH.VarE nm) = + SnGen.varE $ SnGen.mkName $ fullName nm + +expToDocExp (TH.AppE e1 e2) = + SnGen.appE (expToDocExp e1) (expToDocExp e2) + +expToDocExp (TH.ListE es) = + SnGen.listE $ map expToDocExp es + +expToDocExp (TH.TupE es) = + SnGen.tupE $ map (\(Just e) -> expToDocExp e) es + +expToDocExp _ = error "invalid exp" + + +deleteParensE :: TH.Exp -> TH.Exp +deleteParensE (TH.ParensE e) = + deleteParensE e + +deleteParensE (TH.LitE l) = + TH.LitE l + +deleteParensE (TH.ConE nm) = + TH.ConE nm + +deleteParensE (TH.VarE nm) = + TH.VarE nm + +deleteParensE (TH.AppE e1 e2) = + TH.AppE (deleteParensE e1) (deleteParensE e2) + +deleteParensE (TH.ListE es) = + TH.ListE $ map deleteParensE es + +deleteParensE (TH.TupE es) = + TH.TupE $ map (\(Just e) -> Just $ deleteParensE e) es + +deleteParensE _ = error "invalid exp" From 61319a26c3928c85b3ad569a4fd3871b94e9ab08 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Thu, 24 Mar 2022 21:07:28 +0300 Subject: [PATCH 14/39] Add ArithSeqE for DocExp tests generating. Fix in Syntax.arithSeqE and Syntax.intE. `A.` in [A..5] is interpreted as a module name, so a space after `A` is needed here. Change type in Syntax.intE because of (abs (minBound :: Int)) doesn't work correctly. --- .../src/Happy/Backend/CodeCombinators.hs | 2 +- .../Happy/Backend/CodeCombinators/Abstract.hs | 4 +- .../Happy/Backend/CodeCombinators/Syntax.hs | 11 +++-- .../test/Test/CodeCombinators/GenExp.hs | 42 ++++++++++++++----- 4 files changed, 40 insertions(+), 19 deletions(-) diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 2b3a0b71..3a74d4f9 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -20,7 +20,7 @@ class CodeGen e where mkOpName :: String -> NameT e newName :: String -> NewNameM e (NameT e) - intE :: Int -> e + intE :: Integral a => a -> e negateE :: e -> e stringE :: String -> e diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs index 6c4cfade..9d97545f 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs @@ -26,13 +26,13 @@ instance CodeGen TH.Exp where negateE :: TH.Exp -> TH.Exp negateE = TH.AppE (TH.VarE $ mkName "GHC.Num.negate") - intE :: Int -> TH.Exp + intE :: Integral a => a -> TH.Exp intE num | num < 0 = negateE absE | otherwise = absE where absE = TH.LitE $ TH.IntegerL $ - fromIntegral $ abs num + abs $ fromIntegral num stringE :: String -> TH.Exp stringE str = TH.LitE $ TH.StringL str diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index 3946361e..a0f27afb 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -17,7 +17,6 @@ import qualified Text.PrettyPrint as PP import qualified Language.Haskell.TH as TH import Control.Monad.Identity (Identity) - newtype Prec = Prec Int deriving (Eq, Ord, Show, Bounded) @@ -65,16 +64,16 @@ instance CodeGen DocExp where negateE :: DocExp -> DocExp negateE = appE $ varE $ mkName "GHC.Num.negate" - intE :: Int -> DocExp + intE :: Integral a => a -> DocExp intE num - | num < 0 = negateE absE + | num < 0 = negateE $ absE | otherwise = absE where absE = DocExp $ \_ -> - PP.int $ abs num + PP.integer $ abs $ fromIntegral $ num stringE :: String -> DocExp - stringE str = DocExp (\_ -> PP.doubleQuotes $ PP.text $ escape str) + stringE str = DocExp $ \_ -> PP.doubleQuotes $ PP.text $ escape str where escape ('\'':xs) = '\\' : '\'' : escape xs escape ('\"':xs) = '\\' : '\"' : escape xs escape ('\\':xs) = '\\' : '\\' : escape xs @@ -109,7 +108,7 @@ instance CodeGen DocExp where arithSeqE :: DocRange -> DocExp arithSeqE (FromToR (DocExp e1) (DocExp e2)) = DocExp $ \_ -> - PP.brackets $ e1 noPrec <> PP.text ".." <> e2 noPrec + PP.brackets $ e1 noPrec PP.<+> PP.text ".." PP.<+> e2 noPrec conT :: DocName -> DocType conT (DocName name) = DocType $ \_ -> name diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs index 7d5c838b..c463821c 100644 --- a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs +++ b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs @@ -26,7 +26,7 @@ genClassName = do genIntE :: MonadGen m => m TH.Exp genIntE = do x <- Gen.int $ Range.linear minBound maxBound - return $ intE x + return $ intE $ fromIntegral x genStringE :: MonadGen m => m TH.Exp genStringE = do @@ -59,19 +59,26 @@ genListE = do es <- Gen.list (Range.linear 1 20) genExp return $ listE es +genArithSeqE :: MonadGen m => m TH.Exp +genArithSeqE = do + e1 <- genExp + e2 <- genExp + return $ TH.ArithSeqE $ TH.FromToR e1 e2 + genExp :: MonadGen m => m TH.Exp genExp = Gen.recursive Gen.choice [ - genIntE, - genStringE, - genConE, - genVarE + genIntE + , genStringE + , genConE + , genVarE ] [ - genAppE, - genTupE, - genListE + genAppE + , genTupE + , genListE + , genArithSeqE ] @@ -90,7 +97,7 @@ expToDocExp :: TH.Exp -> SnGen.DocExp expToDocExp (TH.LitE l) = case l of TH.StringL str -> SnGen.stringE str - TH.IntegerL num -> SnGen.intE (fromIntegral num) + TH.IntegerL num -> SnGen.intE num _ -> error "invalid literal" expToDocExp (TH.ConE nm) = @@ -108,6 +115,14 @@ expToDocExp (TH.ListE es) = expToDocExp (TH.TupE es) = SnGen.tupE $ map (\(Just e) -> expToDocExp e) es +expToDocExp (TH.ArithSeqE range) = + case range of + TH.FromToR e1 e2 -> + SnGen.arithSeqE $ + SnGen.FromToR (expToDocExp e1) (expToDocExp e2) + _ -> + error "invalid range" + expToDocExp _ = error "invalid exp" @@ -133,4 +148,11 @@ deleteParensE (TH.ListE es) = deleteParensE (TH.TupE es) = TH.TupE $ map (\(Just e) -> Just $ deleteParensE e) es -deleteParensE _ = error "invalid exp" +deleteParensE (TH.ArithSeqE range) = + case range of + TH.FromToR e1 e2 -> + TH.ArithSeqE $ TH.FromToR (deleteParensE e1) (deleteParensE e2) + _ -> + error "invalid range" + +deleteParensE e = error $ "invalid exp" ++ show e From bf84ea9ed07a2ebb3380955cbdd3290bfcf995d4 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Fri, 25 Mar 2022 14:09:41 +0300 Subject: [PATCH 15/39] Add generating 0-length list in hedgehog-tests --- packages/code-combinators/test/Test/CodeCombinators/GenExp.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs index c463821c..be7475b1 100644 --- a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs +++ b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs @@ -56,7 +56,7 @@ genTupE = do genListE :: MonadGen m => m TH.Exp genListE = do - es <- Gen.list (Range.linear 1 20) genExp + es <- Gen.list (Range.linear 0 20) genExp return $ listE es genArithSeqE :: MonadGen m => m TH.Exp From 66afd18c37cad0be90c9a22d96c63861f7b3cf68 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Fri, 25 Mar 2022 14:10:17 +0300 Subject: [PATCH 16/39] Rewrite produceExpListArray using code-combinators --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 61 ++++++++++++++++--- .../src/Happy/Backend/CodeCombinators.hs | 1 + .../Happy/Backend/CodeCombinators/Abstract.hs | 21 ++++++- .../Happy/Backend/CodeCombinators/Syntax.hs | 22 +++++++ 4 files changed, 94 insertions(+), 11 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index a6750bc5..a410320b 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -832,16 +832,59 @@ action array indexed by (terminal * last_state) + state > produceExpListArray > | ghc -> = str "happyExpList :: HappyAddr\n" -> . str "happyExpList = HappyA# \"" --" -> . str (hexChars explist) -> . str "\"#\n\n" --" +> = +> -- happyExpList :: HappyAddr +> -- happyExpList = HappyA# "hexCharsE explist"# +> let happy_exp_list_name = +> mkName "happyExpList" +> in let happy_exp_list_sig = +> sigD happy_exp_list_name (conT $ mkName "HappyAddr") +> in let happy_exp_list_exp = +> appE (conE $ mkName "HappyA#") (hexCharsE explist) +> in let happy_exp_list_dec = +> funD happy_exp_list_name [(clause [] happy_exp_list_exp [])] +> in +> renderDocDecs [ +> [ +> happy_exp_list_sig +> , happy_exp_list_dec +> ] +> ] > | otherwise -> = str "happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" -> . str "happyExpList = Happy_Data_Array.listArray (0," -> . shows table_size . str ") ([" -> . interleave' "," (map shows explist) -> . str "\n\t])\n\n" +> = +> -- happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int +> -- happyExpList = Happy_Data_Array.listArray (0, table_size) [explist] +> let happy_exp_list_name = +> mkName "happyExpList" +> in let happy_exp_list_type = +> appT +> ( +> appT +> (conT $ mkName "Happy_Data_Array.Array") +> intT +> ) +> intT +> in let happy_exp_list_sig = +> sigD happy_exp_list_name happy_exp_list_type +> in let happy_exp_list_exp = +> appE +> ( +> appE +> (varE $ mkName "Happy_Data_Array.listArray") +> (tupE [intE 0, intE table_size]) +> ) +> ( +> listE $ intE <$> explist +> ) +> in let happy_exp_list_dec = +> funD happy_exp_list_name [(clause [] happy_exp_list_exp [])] +> in +> renderDocDecs [ +> [ +> happy_exp_list_sig +> , happy_exp_list_dec +> ] +> ] > (_, last_state) = bounds action > n_states = last_state + 1 diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 3a74d4f9..75451186 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -23,6 +23,7 @@ class CodeGen e where intE :: Integral a => a -> e negateE :: e -> e stringE :: String -> e + hexCharsE :: [Int] -> e conE :: NameT e -> e varE :: NameT e -> e diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs index 9d97545f..d55c979d 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs @@ -1,9 +1,8 @@ -{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} -{-# OPTIONS_GHC -Wno-orphans #-} module Happy.Backend.CodeCombinators.Abstract where import Happy.Backend.CodeCombinators import qualified Language.Haskell.TH as TH +import Data.Word instance CodeGen TH.Exp where type NameT TH.Exp = TH.Name @@ -37,6 +36,24 @@ instance CodeGen TH.Exp where stringE :: String -> TH.Exp stringE str = TH.LitE $ TH.StringL str + hexCharsE :: [Int] -> TH.Exp + hexCharsE ls = + TH.LitE $ TH.StringPrimL hexChars + where + -- these functions are analogues of the functions from ProduceCode.lhs (happy-backend-lalr package) + hexChars :: [Word8] + hexChars = concatMap hexChar ls + + hexChar :: Int -> [Word8] + hexChar i | i < 0 = hexChar (i + 65536) + hexChar i = toHex (i `mod` 256) ++ toHex (i `div` 256) + + toHex :: Int -> [Word8] + toHex i = [hexDig (i `div` 16), hexDig (i `mod` 16)] + + hexDig :: Int -> Word8 + hexDig = fromIntegral + conE :: TH.Name -> TH.Exp conE = TH.ConE diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index a0f27afb..620ca5d8 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -16,6 +16,8 @@ import Happy.Backend.CodeCombinators import qualified Text.PrettyPrint as PP import qualified Language.Haskell.TH as TH import Control.Monad.Identity (Identity) +import Data.Word +import Data.Char (chr, ord) newtype Prec = Prec Int deriving (Eq, Ord, Show, Bounded) @@ -80,6 +82,26 @@ instance CodeGen DocExp where escape (x:xs) = x : escape xs escape [] = [] + hexCharsE :: [Int] -> DocExp + hexCharsE ls = + DocExp $ \_ -> + (PP.doubleQuotes $ PP.text hexChars) PP.<> PP.text "#" + where + -- these functions are taken from ProduceCode.lhs (happy-backend-lalr package) + hexChars :: String + hexChars = concatMap hexChar ls + + hexChar :: Int -> String + hexChar i | i < 0 = hexChar (i + 65536) + hexChar i = toHex (i `mod` 256) ++ toHex (i `div` 256) + + toHex :: Int -> String + toHex i = ['\\','x', hexDig (i `div` 16), hexDig (i `mod` 16)] + + hexDig :: Int -> Char + hexDig i | i <= 9 = chr (i + ord '0') + | otherwise = chr (i - 10 + ord 'a') + conE :: DocName -> DocExp conE (DocName name) = DocExp $ \_ -> name From 108a0144ad82d5bb286de9aa078130ddcfbb4a90 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Fri, 25 Mar 2022 14:37:49 +0300 Subject: [PATCH 17/39] Modified getName (now it creates name if name doesn't exist in the map) --- .../src/Happy/Backend/CodeCombinators.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 75451186..233e01bd 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} module Happy.Backend.CodeCombinators where import qualified Language.Haskell.TH as TH @@ -80,10 +78,13 @@ emptyListP = conP (mkName "[]") [] type NameContext e r = StateT (Map.Map String (NameT e)) (NewNameM e) r -createName :: (CodeGen e, Monad (NewNameM e)) => String -> NameContext e () -createName name = do - newName_ <- lift $ newName name - modify $ \treeMap -> Map.insert name newName_ treeMap - -getName :: (CodeGen e, Monad (NewNameM e)) => String -> NameContext e (NameT e) -getName name = gets (Map.! name) +getName :: (CodeGen e, Monad (NewNameM e)) => String -> NameContext e (NameT e) +getName str_name = do + maybe_name <- gets (Map.lookup str_name) + case maybe_name of + Just name -> + return name + Nothing -> do + newName_ <- lift $ newName str_name + modify $ \treeMap -> Map.insert str_name newName_ treeMap + return newName_ From 65691aa4eb1bf6a9d058345807f3653ae9ba4a20 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Fri, 25 Mar 2022 15:34:14 +0300 Subject: [PATCH 18/39] Rewrite produceExpListArray using newNames generating monad --- .../backend-lalr/happy-backend-lalr.cabal | 4 +- .../src/Happy/Backend/LALR/ProduceCode.lhs | 92 +++++++++---------- .../src/Happy/Backend/CodeCombinators.hs | 3 + 3 files changed, 51 insertions(+), 48 deletions(-) diff --git a/packages/backend-lalr/happy-backend-lalr.cabal b/packages/backend-lalr/happy-backend-lalr.cabal index df96c6ed..83bc7648 100644 --- a/packages/backend-lalr/happy-backend-lalr.cabal +++ b/packages/backend-lalr/happy-backend-lalr.cabal @@ -47,12 +47,14 @@ library Happy.Backend.LALR.ProduceCode build-depends: base < 5, array, + mtl > 2, + containers, happy-codegen-common == 1.21.0, happy-grammar == 1.21.0, happy-tabular == 1.21.0, happy-code-combinators == 1.21.0 default-language: Haskell98 - default-extensions: CPP, MagicHash, FlexibleContexts + default-extensions: CPP, MagicHash, FlexibleContexts, TypeApplications ghc-options: -Wall other-modules: Paths_happy_backend_lalr diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index a410320b..4f511cc8 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -27,6 +27,9 @@ The code generator. > import Happy.Backend.CodeCombinators > import Happy.Backend.CodeCombinators.Syntax +> import Control.Monad.State ( evalStateT ) +> import Control.Monad.Identity ( runIdentity, Identity ) +> import qualified Data.Map as Map %----------------------------------------------------------------------------- Produce the complete output file. @@ -611,7 +614,7 @@ machinery to discard states in the parser... % f (Prelude.True, nr) = [token_strs Prelude.!! nr] > produceExpListPerState -> = produceExpListArray +> = renderDocDecs (runIdentity $ evalStateT (produceExpListArray @DocExp) Map.empty) > . str "{-# NOINLINE happyExpListPerState #-}\n" > . renderDocDecs [[happy_exp_list_per_state_dec]] > . nl @@ -830,61 +833,56 @@ action array indexed by (terminal * last_state) + state > . interleave' "," (map shows table) > . str "\n\t])\n\n" +> produceExpListArray :: (CodeGen e, Monad (NewNameM e)) => NameContext e [[DecT e]] > produceExpListArray > | ghc > = > -- happyExpList :: HappyAddr > -- happyExpList = HappyA# "hexCharsE explist"# -> let happy_exp_list_name = -> mkName "happyExpList" -> in let happy_exp_list_sig = -> sigD happy_exp_list_name (conT $ mkName "HappyAddr") -> in let happy_exp_list_exp = -> appE (conE $ mkName "HappyA#") (hexCharsE explist) -> in let happy_exp_list_dec = -> funD happy_exp_list_name [(clause [] happy_exp_list_exp [])] -> in -> renderDocDecs [ -> [ -> happy_exp_list_sig -> , happy_exp_list_dec -> ] -> ] +> do +> happy_exp_list_name <- getName "happyExpList" +> happy_addr_name <- getName "HappyAddr" +> happy_addr_con_name <- getName "HappyA#" +> let happy_exp_list_sig = +> sigD happy_exp_list_name (conT happy_addr_name) +> let happy_exp_list_exp = +> appE (conE happy_addr_con_name) (hexCharsE explist) +> let happy_exp_list_dec = +> funD happy_exp_list_name [(clause [] happy_exp_list_exp [])] +> return [[ happy_exp_list_sig, happy_exp_list_dec]] > | otherwise > = > -- happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int > -- happyExpList = Happy_Data_Array.listArray (0, table_size) [explist] -> let happy_exp_list_name = -> mkName "happyExpList" -> in let happy_exp_list_type = -> appT -> ( -> appT -> (conT $ mkName "Happy_Data_Array.Array") -> intT -> ) -> intT -> in let happy_exp_list_sig = -> sigD happy_exp_list_name happy_exp_list_type -> in let happy_exp_list_exp = -> appE -> ( -> appE -> (varE $ mkName "Happy_Data_Array.listArray") -> (tupE [intE 0, intE table_size]) -> ) -> ( -> listE $ intE <$> explist -> ) -> in let happy_exp_list_dec = -> funD happy_exp_list_name [(clause [] happy_exp_list_exp [])] -> in -> renderDocDecs [ -> [ -> happy_exp_list_sig -> , happy_exp_list_dec -> ] -> ] +> do +> happy_exp_list_name <- getName "happyExpList" +> let data_array_name = +> mkName "Happy_Data_Array.Array" +> let list_array_name = +> mkName "Happy_Data_Array.listArray" +> let happy_exp_list_type = +> appT +> ( +> appT +> (conT data_array_name) +> intT +> ) +> intT +> let happy_exp_list_sig = +> sigD happy_exp_list_name happy_exp_list_type +> let happy_exp_list_exp = +> appE +> ( +> appE +> (varE list_array_name) +> (tupE [intE 0, intE table_size]) +> ) +> ( +> listE $ intE <$> explist +> ) +> let happy_exp_list_dec = +> funD happy_exp_list_name [(clause [] happy_exp_list_exp [])] +> return [[ happy_exp_list_sig, happy_exp_list_dec]] > (_, last_state) = bounds action > n_states = last_state + 1 diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 233e01bd..a5a4b7e8 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -76,8 +76,11 @@ emptyListE = conE $ mkName "[]" emptyListP :: CodeGen e => PatT e emptyListP = conP (mkName "[]") [] +-- this monad keeps map from String names representation to Name type NameContext e r = StateT (Map.Map String (NameT e)) (NewNameM e) r +-- returns the name if it already exists +-- otherwise function creates a new name, puts it in the map, and returns that name getName :: (CodeGen e, Monad (NewNameM e)) => String -> NameContext e (NameT e) getName str_name = do maybe_name <- gets (Map.lookup str_name) From b63d15b7518d069104c80c708ef6e480e3f463cf Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Sat, 26 Mar 2022 11:02:46 +0300 Subject: [PATCH 19/39] Add appManyArgsE for simple code-generation --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 78 ++++++++++--------- .../src/Happy/Backend/CodeCombinators.hs | 4 + 2 files changed, 44 insertions(+), 38 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 4f511cc8..450d91bc 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -649,12 +649,12 @@ machinery to discard states in the parser... > --bit_start = st Prelude.* nr_tokens > bit_start_name = mkName "bit_start" > bit_start_dec = funD bit_start_name [clause [] bit_start_exp []] -> where bit_start_exp = appE (appE mulE st_var) (intE nr_tokens) +> where bit_start_exp = appManyArgsE mulE [st_var, intE nr_tokens] > > --bit_end = (st Prelude.+ 1) Prelude.* nr_tokens > bit_end_name = mkName "bit_end" > bit_end_dec = funD bit_end_name [clause [] bit_end_exp []] -> where bit_end_exp = appE (appE mulE (appE (appE addE st_var) (intE 1))) (intE nr_tokens) +> where bit_end_exp = appManyArgsE mulE [appManyArgsE addE [st_var, intE 1], intE nr_tokens] > > --read_bit = readArrayBit happyExpList > read_bit_name = mkName "read_bit" @@ -665,25 +665,29 @@ machinery to discard states in the parser... > bits_name = mkName "bits" > bits_dec = funD bits_name [clause [] bits_exp []] > where bits_exp = -> appE ( -> appE (varE $ mkName "Prelude.map") -> (varE $ mkName "read_bit") -> ) -> ( -> arithSeqE ( -> FromToR -> (varE bit_start_name) -> (appE (appE subE (varE bit_end_name)) (intE 1)) -> ) -> ) +> appManyArgsE +> (varE $ mkName "Prelude.map") +> [ +> varE read_bit_name +> , arithSeqE $ +> FromToR +> (varE bit_start_name) +> (appManyArgsE subE [varE bit_end_name, intE 1]) +> ] > > --bits_indexed = Prelude.zip bits [0... nr_tokens - 1] > bits_indexed_name = mkName "bits_indexed" > bits_indexed_dec = funD bits_indexed_name [clause [] bits_indexed_exp []] > where bits_indexed_exp = -> appE -> (appE (varE $ mkName "Prelude.zip") (varE bits_name)) -> (arithSeqE $ FromToR (intE 0) (intE $ nr_tokens - 1)) +> appManyArgsE +> (varE $ mkName "Prelude.zip") +> [ +> varE bits_name +> , arithSeqE $ +> FromToR +> (intE 0) +> (intE $ nr_tokens - 1) +> ] > > --f (Prelude.False, _) = []\n" > --f (Prelude.True, nr) = [token_strs Prelude.!! nr]\n @@ -694,24 +698,25 @@ machinery to discard states in the parser... > nr = mkName "nr" > exp2 = > listE [ -> appE ( -> appE -> (varE $ mkName "(Prelude.!!)") -> (varE token_strs_name) -> ) -> (varE nr) +> appManyArgsE +> (varE $ mkName "(Prelude.!!)") +> [ +> varE token_strs_name +> , varE nr +> ] > ] > > --token_strs_expected = Prelude.concatMap f token_strs_name = mkName "token_strs" > token_strs_expected_name = mkName "token_strs_expected" > token_strs_expected_dec = funD token_strs_expected_name [clause [] token_strs_expected_exp []] > where token_strs_expected_exp = -> appE ( -> appE -> (varE $ mkName "Prelude.concatMap") -> (varE f_name) -> ) -> (varE bits_indexed_name) +> appManyArgsE +> (varE $ mkName "Prelude.concatMap") +> [ +> varE f_name +> , varE bits_indexed_name +> ] +> > produceStateFunction goto' (state, acts) > = foldr (.) id (map produceActions assocs_acts) > . foldr (.) id (map produceGotos (assocs gotos)) @@ -849,7 +854,7 @@ action array indexed by (terminal * last_state) + state > appE (conE happy_addr_con_name) (hexCharsE explist) > let happy_exp_list_dec = > funD happy_exp_list_name [(clause [] happy_exp_list_exp [])] -> return [[ happy_exp_list_sig, happy_exp_list_dec]] +> return [[happy_exp_list_sig, happy_exp_list_dec]] > | otherwise > = > -- happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int @@ -871,15 +876,12 @@ action array indexed by (terminal * last_state) + state > let happy_exp_list_sig = > sigD happy_exp_list_name happy_exp_list_type > let happy_exp_list_exp = -> appE -> ( -> appE -> (varE list_array_name) -> (tupE [intE 0, intE table_size]) -> ) -> ( -> listE $ intE <$> explist -> ) +> appManyArgsE +> (varE list_array_name) +> [ +> tupE [intE 0, intE table_size] +> , listE $ intE <$> explist +> ] > let happy_exp_list_dec = > funD happy_exp_list_name [(clause [] happy_exp_list_exp [])] > return [[ happy_exp_list_sig, happy_exp_list_dec]] diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index a5a4b7e8..04daedb4 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -4,6 +4,7 @@ import qualified Language.Haskell.TH as TH import Control.Monad.State import qualified Data.Map as Map import Data.Kind (Type) +import Data.Foldable class CodeGen e where type NameT e = n | n -> e @@ -70,6 +71,9 @@ subE = varE $ mkOpName "Prelude.-" intT :: CodeGen e => TypeT e intT = conT $ mkName "Prelude.Int" +appManyArgsE :: CodeGen e => e -> [e] -> e +appManyArgsE fun args = foldl' appE fun args + emptyListE :: CodeGen e => e emptyListE = conE $ mkName "[]" From c6d8a23dc9b5b8b58437bd709a45aedfd2849c70 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Sat, 26 Mar 2022 11:06:34 +0300 Subject: [PATCH 20/39] Add appManyArgsT for simple code-generation --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 10 +++------- .../src/Happy/Backend/CodeCombinators.hs | 3 +++ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 450d91bc..81f4998a 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -866,13 +866,9 @@ action array indexed by (terminal * last_state) + state > let list_array_name = > mkName "Happy_Data_Array.listArray" > let happy_exp_list_type = -> appT -> ( -> appT -> (conT data_array_name) -> intT -> ) -> intT +> appManyArgsT +> (conT data_array_name) +> [intT, intT] > let happy_exp_list_sig = > sigD happy_exp_list_name happy_exp_list_type > let happy_exp_list_exp = diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index 04daedb4..c4be94f1 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -74,6 +74,9 @@ intT = conT $ mkName "Prelude.Int" appManyArgsE :: CodeGen e => e -> [e] -> e appManyArgsE fun args = foldl' appE fun args +appManyArgsT :: CodeGen e => TypeT e -> [TypeT e] -> TypeT e +appManyArgsT fun args = foldl' appT fun args + emptyListE :: CodeGen e => e emptyListE = conE $ mkName "[]" From 9e5607984be58a12b0122dc6a5ea00e525d322eb Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Sat, 26 Mar 2022 12:18:47 +0300 Subject: [PATCH 21/39] Add DocPat hedgehog tests. Fix bug with escaping in Syntax.litP --- .../happy-code-combinators.cabal | 4 +- .../Happy/Backend/CodeCombinators/Syntax.hs | 25 +++-- packages/code-combinators/test/Test.hs | 10 ++ .../test/Test/CodeCombinators/Common.hs | 29 +++++ .../test/Test/CodeCombinators/GenExp.hs | 25 +---- .../test/Test/CodeCombinators/GenPat.hs | 106 ++++++++++++++++++ 6 files changed, 165 insertions(+), 34 deletions(-) create mode 100644 packages/code-combinators/test/Test/CodeCombinators/Common.hs create mode 100644 packages/code-combinators/test/Test/CodeCombinators/GenPat.hs diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index 6ab3122a..9675ce01 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -63,7 +63,9 @@ test-suite test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: - Test.CodeCombinators.GenExp + Test.CodeCombinators.Common + , Test.CodeCombinators.GenExp + , Test.CodeCombinators.GenPat hs-source-dirs: test diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index 620ca5d8..a5af865b 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -5,10 +5,12 @@ module Happy.Backend.CodeCombinators.Syntax DocClause(..), DocDec(..), DocRange(..), + DocPat(..), CodeGen(..), renderDocDecs, renderDocDec, - render + renderE, + renderP ) where @@ -76,11 +78,6 @@ instance CodeGen DocExp where stringE :: String -> DocExp stringE str = DocExp $ \_ -> PP.doubleQuotes $ PP.text $ escape str - where escape ('\'':xs) = '\\' : '\'' : escape xs - escape ('\"':xs) = '\\' : '\"' : escape xs - escape ('\\':xs) = '\\' : '\\' : escape xs - escape (x:xs) = x : escape xs - escape [] = [] hexCharsE :: [Int] -> DocExp hexCharsE ls = @@ -145,8 +142,8 @@ instance CodeGen DocExp where PP.sep [t1 appPrec, t2 atomPrec] litP :: TH.Lit -> DocPat - litP (TH.CharL c) = DocPat $ \_ -> PP.quotes $ PP.text [c] - litP (TH.StringL s) = DocPat $ \_ -> PP.doubleQuotes $ PP.text s + litP (TH.CharL c) = DocPat $ \_ -> PP.quotes $ PP.text $ escape [c] + litP (TH.StringL s) = DocPat $ \_ -> PP.doubleQuotes $ PP.text $ escape s litP (TH.IntegerL n) = DocPat $ \_ -> parensIf (n < 0) $ PP.text $ show n varP :: DocName -> DocPat @@ -185,6 +182,11 @@ instance CodeGen DocExp where funD :: DocName -> [DocClause] -> DocDec funD (DocName name) cls = DocDec $ foldr1 (PP.$+$) [name PP.<+> cl | DocClause cl <- cls] +escape ('\'':xs) = '\\' : '\'' : escape xs +escape ('\"':xs) = '\\' : '\"' : escape xs +escape ('\\':xs) = '\\' : '\\' : escape xs +escape (x:xs) = x : escape xs +escape [] = [] fromTextDetails :: PP.TextDetails -> ShowS fromTextDetails td = @@ -193,8 +195,11 @@ fromTextDetails td = PP.Str str -> (str++) PP.PStr str -> (str++) -render :: DocExp -> ShowS -render (DocExp exp) = showString $ PP.render $ exp noPrec +renderE :: DocExp -> ShowS +renderE (DocExp exp) = showString $ PP.render $ exp noPrec + +renderP :: DocPat -> ShowS +renderP (DocPat pat) = showString $ PP.render $ pat noPrec renderDocDec :: DocDec -> ShowS diff --git a/packages/code-combinators/test/Test.hs b/packages/code-combinators/test/Test.hs index c1c05a21..e25df8d2 100644 --- a/packages/code-combinators/test/Test.hs +++ b/packages/code-combinators/test/Test.hs @@ -3,6 +3,7 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Language.Haskell.TH as TH import Test.CodeCombinators.GenExp +import Test.CodeCombinators.GenPat import Language.Haskell.Meta.Parse import Data.Either @@ -15,6 +16,15 @@ prop_exp = let Right result = parse_result exp === deleteParensE result +prop_pat :: Property +prop_pat = + property $ do + pat <- forAll genPat + let parse_result = parsePat (patToString pat) + assert $ isRight parse_result + let Right result = parse_result + pat === deleteParensP result + main :: IO Bool main = checkParallel $$(discover) diff --git a/packages/code-combinators/test/Test/CodeCombinators/Common.hs b/packages/code-combinators/test/Test/CodeCombinators/Common.hs new file mode 100644 index 00000000..376464f1 --- /dev/null +++ b/packages/code-combinators/test/Test/CodeCombinators/Common.hs @@ -0,0 +1,29 @@ +module Test.CodeCombinators.Common where + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Language.Haskell.TH as TH +import qualified Happy.Backend.CodeCombinators.Abstract as AbsGen +import Happy.Backend.CodeCombinators + +genFunName :: MonadGen m => m TH.Name +genFunName = do + name_tail <- Gen.list (Range.linear 1 10) Gen.alphaNum + name_head <- Gen.lower + return $ mkName $ (name_head : name_tail) ++ "_" + +genClassName :: MonadGen m => m TH.Name +genClassName = do + name_tail <- Gen.list (Range.linear 1 10) Gen.alphaNum + name_head <- Gen.upper + return $ mkName $ (name_head : name_tail) ++ "_" + +fullName :: TH.Name -> String +fullName nm = + moduleName ++ TH.nameBase nm + where moduleName = + case TH.nameModule nm of + Just str -> str ++ "." + Nothing -> "" + diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs index be7475b1..4dc5f12d 100644 --- a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs +++ b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs @@ -7,22 +7,10 @@ import qualified Language.Haskell.TH as TH import qualified Happy.Backend.CodeCombinators.Syntax as SnGen import qualified Happy.Backend.CodeCombinators.Abstract as AbsGen import Happy.Backend.CodeCombinators +import Test.CodeCombinators.Common import Data.List import Data.Maybe - -genFunName :: MonadGen m => m TH.Name -genFunName = do - name_tail <- Gen.list (Range.linear 1 10) Gen.alphaNum - name_head <- Gen.lower - return $ mkName $ (name_head : name_tail) ++ "_" - -genClassName :: MonadGen m => m TH.Name -genClassName = do - name_tail <- Gen.list (Range.linear 1 10) Gen.alphaNum - name_head <- Gen.upper - return $ mkName $ (name_head : name_tail) ++ "_" - genIntE :: MonadGen m => m TH.Exp genIntE = do x <- Gen.int $ Range.linear minBound maxBound @@ -81,17 +69,8 @@ genExp = , genArithSeqE ] - -fullName :: TH.Name -> String -fullName nm = - moduleName ++ TH.nameBase nm - where moduleName = - case TH.nameModule nm of - Just str -> str ++ "." - Nothing -> "" - expToString :: TH.Exp -> String -expToString e = SnGen.render (expToDocExp e) "" +expToString e = SnGen.renderE (expToDocExp e) "" expToDocExp :: TH.Exp -> SnGen.DocExp expToDocExp (TH.LitE l) = diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenPat.hs b/packages/code-combinators/test/Test/CodeCombinators/GenPat.hs new file mode 100644 index 00000000..db2a18c2 --- /dev/null +++ b/packages/code-combinators/test/Test/CodeCombinators/GenPat.hs @@ -0,0 +1,106 @@ +module Test.CodeCombinators.GenPat where + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Language.Haskell.TH as TH +import qualified Happy.Backend.CodeCombinators.Syntax as SnGen +import qualified Happy.Backend.CodeCombinators.Abstract as AbsGen +import Happy.Backend.CodeCombinators +import Test.CodeCombinators.Common +import Data.List + + +genLitP :: MonadGen m => m TH.Pat +genLitP = do + x <- Gen.choice $ + [ + do + c <- Gen.latin1 + return $ litP $ TH.CharL c + , do + s <- Gen.list (Range.linear 0 20) Gen.latin1 + return $ litP $ TH.StringL $ delete '\n' s + , do + x <- Gen.int $ Range.linear minBound maxBound + return $ litP $ TH.IntegerL $ fromIntegral x + ] + return x + +genBoolP :: MonadGen m => m TH.Pat +genBoolP = Gen.element [trueP, falseP] + +genVarP :: MonadGen m => m TH.Pat +genVarP = do + varName <- genFunName + return $ varP varName + +genWildP :: MonadGen m => m TH.Pat +genWildP = return wildP + +genConP :: MonadGen m => m TH.Pat +genConP = do + conName <- genClassName + ps <- Gen.list (Range.linear 2 20) genPat + return $ conP conName ps + +genTupP :: MonadGen m => m TH.Pat +genTupP = do + ps <- Gen.list (Range.linear 2 20) genPat + return $ tupP ps + +genPat :: MonadGen m => m TH.Pat +genPat = + Gen.recursive Gen.choice + [ + genLitP + , genBoolP + , genVarP + , genWildP + ] + [ + genConP + , genTupP + ] + +patToString :: TH.Pat -> String +patToString p = SnGen.renderP (patToDocPat p) "" + +patToDocPat :: TH.Pat -> SnGen.DocPat +patToDocPat (TH.LitP p) = SnGen.litP p + +patToDocPat (TH.ConP nm ps) = + SnGen.conP + (SnGen.mkName $ fullName nm) + (map patToDocPat ps) + +patToDocPat (TH.VarP nm) = + SnGen.varP $ SnGen.mkName $ fullName nm + +patToDocPat (TH.TupP ps) = + SnGen.tupP $ map patToDocPat ps + +patToDocPat TH.WildP = + SnGen.wildP + +patToDocPat _ = error "invalid pat" + + +deleteParensP :: TH.Pat -> TH.Pat +deleteParensP (TH.ParensP p) = deleteParensP p + +deleteParensP (TH.LitP p) = TH.LitP p + +deleteParensP (TH.ConP nm ps) = + TH.ConP nm $ map deleteParensP ps + +deleteParensP (TH.VarP nm) = + TH.VarP nm + +deleteParensP (TH.TupP ps) = + TH.TupP $ map deleteParensP ps + +deleteParensP TH.WildP = + TH.WildP + +deleteParensP p = error $ "invalid exp" ++ show p From 5f830304d22078deea5fc68e7c829be95973355e Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Mon, 28 Mar 2022 20:26:20 +0300 Subject: [PATCH 22/39] Add appManyArgsE to hedgehog tests --- .../code-combinators/test/Test/CodeCombinators/GenExp.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs index 4dc5f12d..172ef13a 100644 --- a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs +++ b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs @@ -37,6 +37,12 @@ genAppE = do e2 <- genExp return $ appE e1 e2 +genAppManyArgsE :: MonadGen m => m TH.Exp +genAppManyArgsE = do + e <- genExp + es <- Gen.list (Range.linear 0 5) genExp + return $ appManyArgsE e es + genTupE :: MonadGen m => m TH.Exp genTupE = do es <- Gen.list (Range.linear 2 20) genExp @@ -67,6 +73,7 @@ genExp = , genTupE , genListE , genArithSeqE + , genAppManyArgsE ] expToString :: TH.Exp -> String From 58bd64ec36eee9cb80c3f45530f6e9a612dacbac Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Mon, 28 Mar 2022 21:21:04 +0300 Subject: [PATCH 23/39] Add hedgehog DocType generating tests --- .../happy-code-combinators.cabal | 1 + .../Happy/Backend/CodeCombinators/Syntax.hs | 7 +- packages/code-combinators/test/Test.hs | 10 +++ .../test/Test/CodeCombinators/GenType.hs | 80 +++++++++++++++++++ 4 files changed, 97 insertions(+), 1 deletion(-) create mode 100644 packages/code-combinators/test/Test/CodeCombinators/GenType.hs diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index 9675ce01..9271eb2f 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -66,6 +66,7 @@ test-suite test Test.CodeCombinators.Common , Test.CodeCombinators.GenExp , Test.CodeCombinators.GenPat + , Test.CodeCombinators.GenType hs-source-dirs: test diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index a5af865b..6144f338 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -6,11 +6,13 @@ module Happy.Backend.CodeCombinators.Syntax DocDec(..), DocRange(..), DocPat(..), + DocType(..), CodeGen(..), renderDocDecs, renderDocDec, renderE, - renderP + renderP, + renderT ) where @@ -201,6 +203,9 @@ renderE (DocExp exp) = showString $ PP.render $ exp noPrec renderP :: DocPat -> ShowS renderP (DocPat pat) = showString $ PP.render $ pat noPrec +renderT :: DocType -> ShowS +renderT (DocType tp) = showString $ PP.render $ tp noPrec + renderDocDec :: DocDec -> ShowS renderDocDec (DocDec dec) = showString $ PP.render dec diff --git a/packages/code-combinators/test/Test.hs b/packages/code-combinators/test/Test.hs index e25df8d2..41c960d4 100644 --- a/packages/code-combinators/test/Test.hs +++ b/packages/code-combinators/test/Test.hs @@ -4,6 +4,7 @@ import qualified Hedgehog.Range as Range import qualified Language.Haskell.TH as TH import Test.CodeCombinators.GenExp import Test.CodeCombinators.GenPat +import Test.CodeCombinators.GenType import Language.Haskell.Meta.Parse import Data.Either @@ -25,6 +26,15 @@ prop_pat = let Right result = parse_result pat === deleteParensP result +prop_type :: Property +prop_type = + property $ do + pat <- forAll genType + let parse_result = parseType (typeToString pat) + assert $ isRight parse_result + let Right result = parse_result + pat === deleteParensT result + main :: IO Bool main = checkParallel $$(discover) diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenType.hs b/packages/code-combinators/test/Test/CodeCombinators/GenType.hs new file mode 100644 index 00000000..49b26e85 --- /dev/null +++ b/packages/code-combinators/test/Test/CodeCombinators/GenType.hs @@ -0,0 +1,80 @@ +module Test.CodeCombinators.GenType where + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Language.Haskell.TH as TH +import qualified Happy.Backend.CodeCombinators.Syntax as SnGen +import qualified Happy.Backend.CodeCombinators.Abstract as AbsGen +import Happy.Backend.CodeCombinators +import Test.CodeCombinators.Common +import Data.List + +genIntT :: MonadGen m => m TH.Type +genIntT = return $ intT + +genConT :: MonadGen m => m TH.Type +genConT = do + conName <- genClassName + return $ conT conName + +genVarT :: MonadGen m => m TH.Type +genVarT = do + varName <- genFunName + return $ varT varName + +genAppT :: MonadGen m => m TH.Type +genAppT = do + t1 <- genType + t2 <- genType + return $ appT t1 t2 + +genAppManyArgsT :: MonadGen m => m TH.Type +genAppManyArgsT = do + t <- genType + ts <- Gen.list (Range.linear 0 5) genType + return $ appManyArgsT t ts + +genType :: MonadGen m => m TH.Type +genType = + Gen.recursive Gen.choice + [ + genIntT + , genConT + , genVarT + ] + [ + genAppT + , genAppManyArgsT + ] + +typeToString :: TH.Type -> String +typeToString e = SnGen.renderT (typeToDocType e) "" + +typeToDocType :: TH.Type -> SnGen.DocType +typeToDocType (TH.ConT nm) = + SnGen.conT $ SnGen.mkName $ fullName nm + +typeToDocType (TH.VarT nm) = + SnGen.varT $ SnGen.mkName $ fullName nm + +typeToDocType (TH.AppT e1 e2) = + SnGen.appT (typeToDocType e1) (typeToDocType e2) + +typeToDocType _ = error "invalid type" + + +deleteParensT :: TH.Type -> TH.Type +deleteParensT (TH.ParensT t) = + deleteParensT t + +deleteParensT (TH.ConT nm) = + TH.ConT nm + +deleteParensT (TH.VarT nm) = + TH.VarT nm + +deleteParensT (TH.AppT t1 t2) = + TH.AppT (deleteParensT t1) (deleteParensT t2) + +deleteParensT t = error $ "invalid type" ++ show t From 3317663ea5df4c0877df4b79e3fa57e75ad583c9 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Mon, 28 Mar 2022 23:03:09 +0300 Subject: [PATCH 24/39] Add hedgeog tests for [DocDec] generating. Fix bug in Syntax.clause. I used wrong precedence in patter-generating inside Syntax.clause, so no brackets were generated when they were needed. --- .../happy-code-combinators.cabal | 1 + .../Happy/Backend/CodeCombinators/Syntax.hs | 2 +- packages/code-combinators/test/Test.hs | 10 +++ .../test/Test/CodeCombinators/GenDec.hs | 76 +++++++++++++++++++ 4 files changed, 88 insertions(+), 1 deletion(-) create mode 100644 packages/code-combinators/test/Test/CodeCombinators/GenDec.hs diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index 9271eb2f..adb9cdaa 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -67,6 +67,7 @@ test-suite test , Test.CodeCombinators.GenExp , Test.CodeCombinators.GenPat , Test.CodeCombinators.GenType + , Test.CodeCombinators.GenDec hs-source-dirs: test diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index 6144f338..b689a7b4 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -169,7 +169,7 @@ instance CodeGen DocExp where clause :: [DocPat] -> DocExp -> [DocDec] -> DocClause clause ps (DocExp exp) decs = DocClause $ - (PP.sep [p noPrec | DocPat p <- ps] PP.<+> PP.text "=" PP.<+> exp noPrec) + (PP.sep [p atomPrec | DocPat p <- ps] PP.<+> PP.text "=" PP.<+> exp noPrec) PP.$+$ PP.nest 4 whereSection where whereSection = case decs of diff --git a/packages/code-combinators/test/Test.hs b/packages/code-combinators/test/Test.hs index 41c960d4..6d9ede38 100644 --- a/packages/code-combinators/test/Test.hs +++ b/packages/code-combinators/test/Test.hs @@ -5,6 +5,7 @@ import qualified Language.Haskell.TH as TH import Test.CodeCombinators.GenExp import Test.CodeCombinators.GenPat import Test.CodeCombinators.GenType +import Test.CodeCombinators.GenDec import Language.Haskell.Meta.Parse import Data.Either @@ -35,6 +36,15 @@ prop_type = let Right result = parse_result pat === deleteParensT result +prop_dec :: Property +prop_dec = + property $ do + ds <- forAll genDecList + let parse_result = parseDecs (decListToString ds) + assert $ isRight parse_result + let Right result = parse_result + ds === deleteParensDecList result + main :: IO Bool main = checkParallel $$(discover) diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenDec.hs b/packages/code-combinators/test/Test/CodeCombinators/GenDec.hs new file mode 100644 index 00000000..e6786eaa --- /dev/null +++ b/packages/code-combinators/test/Test/CodeCombinators/GenDec.hs @@ -0,0 +1,76 @@ +module Test.CodeCombinators.GenDec where + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Language.Haskell.TH as TH +import qualified Happy.Backend.CodeCombinators.Syntax as SnGen +import Happy.Backend.CodeCombinators +import Test.CodeCombinators.Common +import Test.CodeCombinators.GenExp +import Test.CodeCombinators.GenPat +import Test.CodeCombinators.GenType + +genClause :: MonadGen m => Int -> m TH.Clause +genClause pNumber = do + ps <- Gen.list (Range.linear pNumber pNumber) genPat + e <- genExp + ds <- genDecList + return $ clause ps e ds + +genSigD :: MonadGen m => m TH.Dec +genSigD = do + nm <- genFunName + tp <- genType + return $ sigD nm tp + +genFunD :: MonadGen m => m TH.Dec +genFunD = do + nm <- genFunName + pn <- Gen.int $ Range.linear 1 5 + cls <- Gen.list (Range.linear 1 20) (genClause pn) + return $ funD nm cls + +genDecList :: MonadGen m => m [TH.Dec] +genDecList = + Gen.recursive Gen.choice + [ Gen.list (Range.linear 1 5) genSigD ] + [ Gen.list (Range.linear 1 5) genFunD ] + +decListToString :: [TH.Dec] -> String +decListToString ds = SnGen.renderDocDecs [decToDocDec <$> ds] "" + +decToDocDec :: TH.Dec -> SnGen.DocDec +decToDocDec (TH.SigD nm tp) = + SnGen.sigD (SnGen.mkName $ fullName nm) $ typeToDocType tp + +decToDocDec (TH.FunD nm cls) = + SnGen.funD (SnGen.mkName $ fullName nm) + (clauseToDocClause <$> cls) + +decToDocDec _ = error "invalid dec" + +clauseToDocClause :: TH.Clause -> SnGen.DocClause +clauseToDocClause (TH.Clause ps (TH.NormalB e) ds) = + SnGen.clause (patToDocPat <$> ps) (expToDocExp e) (decToDocDec <$> ds) + +clauseToDocClause c = error $ "invalid сlause" ++ show c + +deleteParensDecList :: [TH.Dec] -> [TH.Dec] +deleteParensDecList = map deleteParensD + +deleteParensD :: TH.Dec -> TH.Dec +deleteParensD (TH.SigD nm tp) = + TH.SigD nm $ deleteParensT tp + +deleteParensD (TH.FunD nm cls) = + TH.FunD nm $ + deleteParensC <$> cls + +deleteParensD d = error $ "invalid dec" ++ show d + +deleteParensC :: TH.Clause -> TH.Clause +deleteParensC (TH.Clause ps (TH.NormalB e) ds) = + TH.Clause (deleteParensP <$> ps) (TH.NormalB $ deleteParensE e) (deleteParensD <$> ds) + +deleteParensC c = error $ "invalid сlause" ++ show c From d6f09125f009ba46b3cc27d2c6053006ba1ead76 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 12:16:34 +0300 Subject: [PATCH 25/39] Fix new blank line at EOF --- packages/code-combinators/test/Test.hs | 1 - packages/code-combinators/test/Test/CodeCombinators/Common.hs | 1 - 2 files changed, 2 deletions(-) diff --git a/packages/code-combinators/test/Test.hs b/packages/code-combinators/test/Test.hs index 6d9ede38..330ac6f5 100644 --- a/packages/code-combinators/test/Test.hs +++ b/packages/code-combinators/test/Test.hs @@ -47,4 +47,3 @@ prop_dec = main :: IO Bool main = checkParallel $$(discover) - diff --git a/packages/code-combinators/test/Test/CodeCombinators/Common.hs b/packages/code-combinators/test/Test/CodeCombinators/Common.hs index 376464f1..e6ae9a00 100644 --- a/packages/code-combinators/test/Test/CodeCombinators/Common.hs +++ b/packages/code-combinators/test/Test/CodeCombinators/Common.hs @@ -26,4 +26,3 @@ fullName nm = case TH.nameModule nm of Just str -> str ++ "." Nothing -> "" - From b8a9f15b6c0d7d244c4808641a035e0266dd1638 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 12:35:40 +0300 Subject: [PATCH 26/39] Fix order of extensions and etc in cabal file. Now such listings are in alphabetical order. --- .../happy-code-combinators.cabal | 29 +++++++++---------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index adb9cdaa..7e8c95ca 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -38,23 +38,23 @@ library hs-source-dirs: src exposed-modules: Happy.Backend.CodeCombinators, - Happy.Backend.CodeCombinators.Syntax, - Happy.Backend.CodeCombinators.Abstract + Happy.Backend.CodeCombinators.Abstract, + Happy.Backend.CodeCombinators.Syntax - build-depends: base < 5, - array, - pretty, - template-haskell, + build-depends: array, + base < 5, + containers, mtl, - containers + pretty, + template-haskell default-language: Haskell98 default-extensions: CPP, - MagicHash, + FlexibleContexts, InstanceSigs, - TypeFamilyDependencies, KindSignatures, - FlexibleContexts + MagicHash, + TypeFamilyDependencies ghc-options: -Wall @@ -65,9 +65,9 @@ test-suite test other-modules: Test.CodeCombinators.Common , Test.CodeCombinators.GenExp + , Test.CodeCombinators.GenDec , Test.CodeCombinators.GenPat , Test.CodeCombinators.GenType - , Test.CodeCombinators.GenDec hs-source-dirs: test @@ -78,11 +78,10 @@ test-suite test ghc-options: -Wall build-depends: - HUnit - , base < 5 - , hedgehog - , template-haskell + base < 5 , happy-code-combinators , haskell-src-meta + , hedgehog + , template-haskell default-language: Haskell98 From 99e0bb33262447ed30ac171861e9aff3c653e3ab Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 12:56:35 +0300 Subject: [PATCH 27/39] Fix Issue#2. Put correct package-description in cabal-file. --- packages/code-combinators/happy-code-combinators.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index 7e8c95ca..0b8df94f 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -15,8 +15,8 @@ synopsis: Code combinators for simple code generation Description: Happy is a parser generator for Haskell. - Happy-Backend-LALR is responsible for code-generation: - It converts action and goto tables into LALR Haskell code. + Happy-Backend-CodeCombinators allows to generate code + in both abstract and text represantation. tested-with: From 800027b0cf82f57c7d9175add2c954a30f542bb2 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 13:10:13 +0300 Subject: [PATCH 28/39] Add (Monad (NewNameM e)) condition for CodeGen class. --- packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs | 2 +- .../code-combinators/src/Happy/Backend/CodeCombinators.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 81f4998a..b4450825 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -838,7 +838,7 @@ action array indexed by (terminal * last_state) + state > . interleave' "," (map shows table) > . str "\n\t])\n\n" -> produceExpListArray :: (CodeGen e, Monad (NewNameM e)) => NameContext e [[DecT e]] +> produceExpListArray :: CodeGen e => NameContext e [[DecT e]] > produceExpListArray > | ghc > = diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index c4be94f1..f6a83dae 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -6,7 +6,7 @@ import qualified Data.Map as Map import Data.Kind (Type) import Data.Foldable -class CodeGen e where +class Monad (NewNameM e) => CodeGen e where type NameT e = n | n -> e type RangeT e = r | r -> e type TypeT e = t | t -> e @@ -88,7 +88,7 @@ type NameContext e r = StateT (Map.Map String (NameT e)) (NewNameM e) r -- returns the name if it already exists -- otherwise function creates a new name, puts it in the map, and returns that name -getName :: (CodeGen e, Monad (NewNameM e)) => String -> NameContext e (NameT e) +getName :: CodeGen e => String -> NameContext e (NameT e) getName str_name = do maybe_name <- gets (Map.lookup str_name) case maybe_name of From 130406d45a27b5eb90f576edb3e82e9f3f5db28c Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 13:48:41 +0300 Subject: [PATCH 29/39] Add instance IsString (NameT e). Now it is possible to avoid frequent use of mkName in code. --- .../backend-lalr/happy-backend-lalr.cabal | 2 +- .../src/Happy/Backend/LALR/ProduceCode.lhs | 46 +++++++++---------- .../happy-code-combinators.cabal | 1 + .../src/Happy/Backend/CodeCombinators.hs | 18 ++++---- .../Happy/Backend/CodeCombinators/Abstract.hs | 4 ++ .../Happy/Backend/CodeCombinators/Syntax.hs | 4 ++ 6 files changed, 42 insertions(+), 33 deletions(-) diff --git a/packages/backend-lalr/happy-backend-lalr.cabal b/packages/backend-lalr/happy-backend-lalr.cabal index 83bc7648..01780c56 100644 --- a/packages/backend-lalr/happy-backend-lalr.cabal +++ b/packages/backend-lalr/happy-backend-lalr.cabal @@ -55,6 +55,6 @@ library happy-code-combinators == 1.21.0 default-language: Haskell98 - default-extensions: CPP, MagicHash, FlexibleContexts, TypeApplications + default-extensions: CPP, MagicHash, FlexibleContexts, TypeApplications, OverloadedStrings ghc-options: -Wall other-modules: Paths_happy_backend_lalr diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index b4450825..5bd38e52 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -598,8 +598,8 @@ machinery to discard states in the parser... > ] > ] > . nl -> where happy_n_terms_name = mkName "happy_n_terms" -> happy_n_nonterms_name = mkName "happy_n_nonterms_name" +> where happy_n_terms_name = "happy_n_terms" +> happy_n_nonterms_name = "happy_n_nonterms_name" % {-# NOINLINE happyExpListPerState #-} % happyExpListPerState st = token_strs_expected @@ -622,7 +622,7 @@ machinery to discard states in the parser... > nr_tokens = last_token - first_token + 1 > > --happyExpListPerState st = token_strs_expected -> happy_exp_list_per_state_name = mkName "happyExpListPerState" +> happy_exp_list_per_state_name = "happyExpListPerState" > happy_exp_list_per_state_dec = > funD happy_exp_list_per_state_name [ > clause [st_pat] (varE token_strs_expected_name) [ @@ -637,36 +637,36 @@ machinery to discard states in the parser... > ] > ] > -> st_name = mkName "st" +> st_name = "st" > st_var = varE st_name > st_pat = varP st_name > > --token_strs = elems token_names' -> token_strs_name = mkName "token_strs" +> token_strs_name = "token_strs" > token_strs_dec = funD token_strs_name [clause [] token_strs_exp []] > where token_strs_exp = listE [stringE str_elem | str_elem <- elems token_names'] > > --bit_start = st Prelude.* nr_tokens -> bit_start_name = mkName "bit_start" +> bit_start_name = "bit_start" > bit_start_dec = funD bit_start_name [clause [] bit_start_exp []] > where bit_start_exp = appManyArgsE mulE [st_var, intE nr_tokens] > > --bit_end = (st Prelude.+ 1) Prelude.* nr_tokens -> bit_end_name = mkName "bit_end" +> bit_end_name = "bit_end" > bit_end_dec = funD bit_end_name [clause [] bit_end_exp []] > where bit_end_exp = appManyArgsE mulE [appManyArgsE addE [st_var, intE 1], intE nr_tokens] > > --read_bit = readArrayBit happyExpList -> read_bit_name = mkName "read_bit" +> read_bit_name = "read_bit" > read_bit_dec = funD read_bit_name [clause [] read_bit_exp []] -> where read_bit_exp = appE (varE $ mkName "readArrayBit") (varE $ mkName "happyExpList") +> where read_bit_exp = appE (varE "readArrayBit") (varE "happyExpList") > > --bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] -> bits_name = mkName "bits" +> bits_name = "bits" > bits_dec = funD bits_name [clause [] bits_exp []] > where bits_exp = > appManyArgsE -> (varE $ mkName "Prelude.map") +> (varE "Prelude.map") > [ > varE read_bit_name > , arithSeqE $ @@ -676,11 +676,11 @@ machinery to discard states in the parser... > ] > > --bits_indexed = Prelude.zip bits [0... nr_tokens - 1] -> bits_indexed_name = mkName "bits_indexed" +> bits_indexed_name = "bits_indexed" > bits_indexed_dec = funD bits_indexed_name [clause [] bits_indexed_exp []] > where bits_indexed_exp = > appManyArgsE -> (varE $ mkName "Prelude.zip") +> (varE "Prelude.zip") > [ > varE bits_name > , arithSeqE $ @@ -691,27 +691,27 @@ machinery to discard states in the parser... > > --f (Prelude.False, _) = []\n" > --f (Prelude.True, nr) = [token_strs Prelude.!! nr]\n -> f_name = mkName "f" +> f_name = "f" > f_dec = funD f_name [clause1, clause2] > where clause1 = clause [tupP [falseP, wildP]] emptyListE [] > clause2 = clause [tupP [trueP, varP nr]] exp2 [] -> nr = mkName "nr" +> nr = "nr" > exp2 = > listE [ > appManyArgsE -> (varE $ mkName "(Prelude.!!)") +> (varE "(Prelude.!!)") > [ > varE token_strs_name > , varE nr > ] > ] > -> --token_strs_expected = Prelude.concatMap f token_strs_name = mkName "token_strs" -> token_strs_expected_name = mkName "token_strs_expected" +> --token_strs_expected = Prelude.concatMap f token_strs_name = "token_strs" +> token_strs_expected_name = "token_strs_expected" > token_strs_expected_dec = funD token_strs_expected_name [clause [] token_strs_expected_exp []] > where token_strs_expected_exp = > appManyArgsE -> (varE $ mkName "Prelude.concatMap") +> (varE "Prelude.concatMap") > [ > varE f_name > , varE bits_indexed_name @@ -838,7 +838,7 @@ action array indexed by (terminal * last_state) + state > . interleave' "," (map shows table) > . str "\n\t])\n\n" -> produceExpListArray :: CodeGen e => NameContext e [[DecT e]] +> produceExpListArray :: (CodeGen e, Monad (NewNameM e)) => NameContext e [[DecT e]] > produceExpListArray > | ghc > = @@ -861,10 +861,8 @@ action array indexed by (terminal * last_state) + state > -- happyExpList = Happy_Data_Array.listArray (0, table_size) [explist] > do > happy_exp_list_name <- getName "happyExpList" -> let data_array_name = -> mkName "Happy_Data_Array.Array" -> let list_array_name = -> mkName "Happy_Data_Array.listArray" +> let data_array_name = "Happy_Data_Array.Array" +> let list_array_name = "Happy_Data_Array.listArray" > let happy_exp_list_type = > appManyArgsT > (conT data_array_name) diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index 0b8df94f..8fb7b2e6 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -54,6 +54,7 @@ library InstanceSigs, KindSignatures, MagicHash, + OverloadedStrings, TypeFamilyDependencies ghc-options: -Wall diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index f6a83dae..aaf7921a 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -5,8 +5,9 @@ import Control.Monad.State import qualified Data.Map as Map import Data.Kind (Type) import Data.Foldable +import Data.String -class Monad (NewNameM e) => CodeGen e where +class (IsString (NameT e), Monad (NewNameM e)) => CodeGen e where type NameT e = n | n -> e type RangeT e = r | r -> e type TypeT e = t | t -> e @@ -47,17 +48,18 @@ class Monad (NewNameM e) => CodeGen e where sigD :: NameT e -> TypeT e -> DecT e funD :: NameT e -> [ClauseT e] -> DecT e + trueE :: CodeGen e => e -trueE = conE $ mkName "Prelude.True" +trueE = conE "Prelude.True" falseE :: CodeGen e => e -falseE = conE $ mkName "Prelude.False" +falseE = conE "Prelude.False" trueP :: CodeGen e => PatT e -trueP = conP (mkName "Prelude.True") [] +trueP = conP "Prelude.True" [] falseP :: CodeGen e => PatT e -falseP = conP (mkName "Prelude.False") [] +falseP = conP "Prelude.False" [] mulE :: CodeGen e => e mulE = varE $ mkOpName "Prelude.*" @@ -69,7 +71,7 @@ subE :: CodeGen e => e subE = varE $ mkOpName "Prelude.-" intT :: CodeGen e => TypeT e -intT = conT $ mkName "Prelude.Int" +intT = conT "Prelude.Int" appManyArgsE :: CodeGen e => e -> [e] -> e appManyArgsE fun args = foldl' appE fun args @@ -78,10 +80,10 @@ appManyArgsT :: CodeGen e => TypeT e -> [TypeT e] -> TypeT e appManyArgsT fun args = foldl' appT fun args emptyListE :: CodeGen e => e -emptyListE = conE $ mkName "[]" +emptyListE = conE "[]" emptyListP :: CodeGen e => PatT e -emptyListP = conP (mkName "[]") [] +emptyListP = conP "[]" [] -- this monad keeps map from String names representation to Name type NameContext e r = StateT (Map.Map String (NameT e)) (NewNameM e) r diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs index d55c979d..178a35f0 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs @@ -3,6 +3,7 @@ module Happy.Backend.CodeCombinators.Abstract where import Happy.Backend.CodeCombinators import qualified Language.Haskell.TH as TH import Data.Word +import Data.String instance CodeGen TH.Exp where type NameT TH.Exp = TH.Name @@ -105,3 +106,6 @@ instance CodeGen TH.Exp where funD :: TH.Name -> [TH.Clause] -> TH.Dec funD = TH.FunD + +instance IsString TH.Name where + fromString = mkName diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index b689a7b4..01f9470e 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -22,6 +22,7 @@ import qualified Language.Haskell.TH as TH import Control.Monad.Identity (Identity) import Data.Word import Data.Char (chr, ord) +import Data.String newtype Prec = Prec Int deriving (Eq, Ord, Show, Bounded) @@ -184,6 +185,9 @@ instance CodeGen DocExp where funD :: DocName -> [DocClause] -> DocDec funD (DocName name) cls = DocDec $ foldr1 (PP.$+$) [name PP.<+> cl | DocClause cl <- cls] +instance IsString DocName where + fromString = mkName + escape ('\'':xs) = '\\' : '\'' : escape xs escape ('\"':xs) = '\\' : '\"' : escape xs escape ('\\':xs) = '\\' : '\\' : escape xs From ea109f12e3cd5db5a1f16fccfa804ca3da60f067 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 14:14:41 +0300 Subject: [PATCH 30/39] Add fullFunD combinator to simplify code generation. --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 26 +++++++------------ .../src/Happy/Backend/CodeCombinators.hs | 9 ++++++- 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 5bd38e52..3700c878 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -588,14 +588,10 @@ machinery to discard states in the parser... > = produceActionArray > . produceReduceArray > . renderDocDecs [ -> [ -> sigD happy_n_terms_name intT, -> funD happy_n_terms_name [clause [] (intE n_terminals) []] -> ], -> [ -> sigD happy_n_nonterms_name intT, -> funD happy_n_nonterms_name [clause [] (intE n_nonterminals) []] -> ] +> fullFunD happy_n_terms_name intT +> [clause [] (intE n_terminals) []] +> , fullFunD happy_n_nonterms_name intT +> [clause [] (intE n_nonterminals) []] > ] > . nl > where happy_n_terms_name = "happy_n_terms" @@ -848,13 +844,12 @@ action array indexed by (terminal * last_state) + state > happy_exp_list_name <- getName "happyExpList" > happy_addr_name <- getName "HappyAddr" > happy_addr_con_name <- getName "HappyA#" -> let happy_exp_list_sig = -> sigD happy_exp_list_name (conT happy_addr_name) > let happy_exp_list_exp = > appE (conE happy_addr_con_name) (hexCharsE explist) > let happy_exp_list_dec = -> funD happy_exp_list_name [(clause [] happy_exp_list_exp [])] -> return [[happy_exp_list_sig, happy_exp_list_dec]] +> fullFunD happy_exp_list_name (conT happy_addr_name) +> [(clause [] happy_exp_list_exp [])] +> return [happy_exp_list_dec] > | otherwise > = > -- happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int @@ -867,8 +862,6 @@ action array indexed by (terminal * last_state) + state > appManyArgsT > (conT data_array_name) > [intT, intT] -> let happy_exp_list_sig = -> sigD happy_exp_list_name happy_exp_list_type > let happy_exp_list_exp = > appManyArgsE > (varE list_array_name) @@ -877,8 +870,9 @@ action array indexed by (terminal * last_state) + state > , listE $ intE <$> explist > ] > let happy_exp_list_dec = -> funD happy_exp_list_name [(clause [] happy_exp_list_exp [])] -> return [[ happy_exp_list_sig, happy_exp_list_dec]] +> fullFunD happy_exp_list_name happy_exp_list_type +> [(clause [] happy_exp_list_exp [])] +> return [happy_exp_list_dec] > (_, last_state) = bounds action > n_states = last_state + 1 diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index aaf7921a..affad933 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -45,7 +45,7 @@ class (IsString (NameT e), Monad (NewNameM e)) => CodeGen e where clause :: [PatT e] -> e -> [DecT e] -> ClauseT e - sigD :: NameT e -> TypeT e -> DecT e + sigD :: NameT e -> TypeT e -> DecT e funD :: NameT e -> [ClauseT e] -> DecT e @@ -85,6 +85,13 @@ emptyListE = conE "[]" emptyListP :: CodeGen e => PatT e emptyListP = conP "[]" [] +fullFunD :: CodeGen e => NameT e -> TypeT e -> [ClauseT e] -> [DecT e] +fullFunD name type_ clauses = + [ + sigD name type_ + , funD name clauses + ] + -- this monad keeps map from String names representation to Name type NameContext e r = StateT (Map.Map String (NameT e)) (NewNameM e) r From abac97d2861c410e354a4f5fa4ece7ab207ee79a Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 15:24:40 +0300 Subject: [PATCH 31/39] Remove redundant (Monad (NewNameM e)) from produceExpListArray context. --- packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 3700c878..a43f4200 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -834,7 +834,7 @@ action array indexed by (terminal * last_state) + state > . interleave' "," (map shows table) > . str "\n\t])\n\n" -> produceExpListArray :: (CodeGen e, Monad (NewNameM e)) => NameContext e [[DecT e]] +> produceExpListArray :: CodeGen e => NameContext e [[DecT e]] > produceExpListArray > | ghc > = From 2e6dca00eba58eebbcb8a14d00dbb37764cc6845 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 18:20:13 +0300 Subject: [PATCH 32/39] Fix some ghc warnings --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 2 +- .../happy-code-combinators.cabal | 2 +- .../src/Happy/Backend/CodeCombinators/Syntax.hs | 16 +++++++--------- 3 files changed, 9 insertions(+), 11 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index a43f4200..0aa23056 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -28,7 +28,7 @@ The code generator. > import Happy.Backend.CodeCombinators > import Happy.Backend.CodeCombinators.Syntax > import Control.Monad.State ( evalStateT ) -> import Control.Monad.Identity ( runIdentity, Identity ) +> import Control.Monad.Identity ( runIdentity ) > import qualified Data.Map as Map %----------------------------------------------------------------------------- diff --git a/packages/code-combinators/happy-code-combinators.cabal b/packages/code-combinators/happy-code-combinators.cabal index 8fb7b2e6..0a7babac 100644 --- a/packages/code-combinators/happy-code-combinators.cabal +++ b/packages/code-combinators/happy-code-combinators.cabal @@ -57,7 +57,7 @@ library OverloadedStrings, TypeFamilyDependencies - ghc-options: -Wall + ghc-options: -Wall -Wno-orphans test-suite test diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index 01f9470e..f018df45 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -20,7 +20,6 @@ import Happy.Backend.CodeCombinators import qualified Text.PrettyPrint as PP import qualified Language.Haskell.TH as TH import Control.Monad.Identity (Identity) -import Data.Word import Data.Char (chr, ord) import Data.String @@ -45,10 +44,7 @@ newtype DocDec = DocDec PP.Doc deriving (Eq, Show) data DocRange - = FromR DocExp - | FromThenR DocExp DocExp - | FromToR DocExp DocExp - | FromThenToR DocExp DocExp DocExp + = FromToR DocExp DocExp instance CodeGen DocExp where type NameT DocExp = DocName @@ -69,7 +65,7 @@ instance CodeGen DocExp where newName = return . mkName negateE :: DocExp -> DocExp - negateE = appE $ varE $ mkName "GHC.Num.negate" + negateE = appE $ varE "GHC.Num.negate" intE :: Integral a => a -> DocExp intE num @@ -148,6 +144,7 @@ instance CodeGen DocExp where litP (TH.CharL c) = DocPat $ \_ -> PP.quotes $ PP.text $ escape [c] litP (TH.StringL s) = DocPat $ \_ -> PP.doubleQuotes $ PP.text $ escape s litP (TH.IntegerL n) = DocPat $ \_ -> parensIf (n < 0) $ PP.text $ show n + litP l = error $ "unsupported literal: " ++ show l varP :: DocName -> DocPat varP (DocName name) = DocPat $ \_ -> name @@ -168,9 +165,9 @@ instance CodeGen DocExp where wildP = DocPat $ \_ -> PP.text "_" clause :: [DocPat] -> DocExp -> [DocDec] -> DocClause - clause ps (DocExp exp) decs = + clause ps (DocExp exp_) decs = DocClause $ - (PP.sep [p atomPrec | DocPat p <- ps] PP.<+> PP.text "=" PP.<+> exp noPrec) + (PP.sep [p atomPrec | DocPat p <- ps] PP.<+> PP.text "=" PP.<+> exp_ noPrec) PP.$+$ PP.nest 4 whereSection where whereSection = case decs of @@ -188,6 +185,7 @@ instance CodeGen DocExp where instance IsString DocName where fromString = mkName +escape :: String -> String escape ('\'':xs) = '\\' : '\'' : escape xs escape ('\"':xs) = '\\' : '\"' : escape xs escape ('\\':xs) = '\\' : '\\' : escape xs @@ -202,7 +200,7 @@ fromTextDetails td = PP.PStr str -> (str++) renderE :: DocExp -> ShowS -renderE (DocExp exp) = showString $ PP.render $ exp noPrec +renderE (DocExp exp_) = showString $ PP.render $ exp_ noPrec renderP :: DocPat -> ShowS renderP (DocPat pat) = showString $ PP.render $ pat noPrec From 6a72c3d53e2b61839f4efe16da9c55cd597471a3 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 18:31:44 +0300 Subject: [PATCH 33/39] Change type of intE --- .../code-combinators/src/Happy/Backend/CodeCombinators.hs | 2 +- .../src/Happy/Backend/CodeCombinators/Syntax.hs | 2 +- packages/code-combinators/test/Test/CodeCombinators/GenExp.hs | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index affad933..c824f53c 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -20,7 +20,7 @@ class (IsString (NameT e), Monad (NewNameM e)) => CodeGen e where mkOpName :: String -> NameT e newName :: String -> NewNameM e (NameT e) - intE :: Integral a => a -> e + intE :: Int -> e negateE :: e -> e stringE :: String -> e hexCharsE :: [Int] -> e diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index f018df45..96df8c5f 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -67,7 +67,7 @@ instance CodeGen DocExp where negateE :: DocExp -> DocExp negateE = appE $ varE "GHC.Num.negate" - intE :: Integral a => a -> DocExp + intE :: Int -> DocExp intE num | num < 0 = negateE $ absE | otherwise = absE diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs index 172ef13a..c6702423 100644 --- a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs +++ b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs @@ -14,7 +14,7 @@ import Data.Maybe genIntE :: MonadGen m => m TH.Exp genIntE = do x <- Gen.int $ Range.linear minBound maxBound - return $ intE $ fromIntegral x + return $ intE x genStringE :: MonadGen m => m TH.Exp genStringE = do @@ -83,7 +83,7 @@ expToDocExp :: TH.Exp -> SnGen.DocExp expToDocExp (TH.LitE l) = case l of TH.StringL str -> SnGen.stringE str - TH.IntegerL num -> SnGen.intE num + TH.IntegerL num -> SnGen.intE $ fromIntegral num _ -> error "invalid literal" expToDocExp (TH.ConE nm) = From f2db12e30fcc4787775c097f3fd005afc05e6f75 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 18:36:58 +0300 Subject: [PATCH 34/39] Fix ghc warnings in code-combinators-tests --- packages/code-combinators/test/Test.hs | 9 +++------ .../code-combinators/test/Test/CodeCombinators/Common.hs | 2 +- .../code-combinators/test/Test/CodeCombinators/GenExp.hs | 3 +-- .../code-combinators/test/Test/CodeCombinators/GenPat.hs | 2 +- .../test/Test/CodeCombinators/GenType.hs | 3 +-- 5 files changed, 7 insertions(+), 12 deletions(-) diff --git a/packages/code-combinators/test/Test.hs b/packages/code-combinators/test/Test.hs index 330ac6f5..5d2760b4 100644 --- a/packages/code-combinators/test/Test.hs +++ b/packages/code-combinators/test/Test.hs @@ -1,7 +1,4 @@ import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import qualified Language.Haskell.TH as TH import Test.CodeCombinators.GenExp import Test.CodeCombinators.GenPat import Test.CodeCombinators.GenType @@ -12,11 +9,11 @@ import Data.Either prop_exp :: Property prop_exp = property $ do - exp <- forAll genExp - let parse_result = parseExp (expToString exp) + exp_ <- forAll genExp + let parse_result = parseExp (expToString exp_) assert $ isRight parse_result let Right result = parse_result - exp === deleteParensE result + exp_ === deleteParensE result prop_pat :: Property prop_pat = diff --git a/packages/code-combinators/test/Test/CodeCombinators/Common.hs b/packages/code-combinators/test/Test/CodeCombinators/Common.hs index e6ae9a00..ad7b7175 100644 --- a/packages/code-combinators/test/Test/CodeCombinators/Common.hs +++ b/packages/code-combinators/test/Test/CodeCombinators/Common.hs @@ -4,7 +4,7 @@ import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Language.Haskell.TH as TH -import qualified Happy.Backend.CodeCombinators.Abstract as AbsGen +import qualified Happy.Backend.CodeCombinators.Abstract() import Happy.Backend.CodeCombinators genFunName :: MonadGen m => m TH.Name diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs index c6702423..486335a2 100644 --- a/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs +++ b/packages/code-combinators/test/Test/CodeCombinators/GenExp.hs @@ -5,11 +5,10 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Language.Haskell.TH as TH import qualified Happy.Backend.CodeCombinators.Syntax as SnGen -import qualified Happy.Backend.CodeCombinators.Abstract as AbsGen +import qualified Happy.Backend.CodeCombinators.Abstract() import Happy.Backend.CodeCombinators import Test.CodeCombinators.Common import Data.List -import Data.Maybe genIntE :: MonadGen m => m TH.Exp genIntE = do diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenPat.hs b/packages/code-combinators/test/Test/CodeCombinators/GenPat.hs index db2a18c2..3ad24803 100644 --- a/packages/code-combinators/test/Test/CodeCombinators/GenPat.hs +++ b/packages/code-combinators/test/Test/CodeCombinators/GenPat.hs @@ -5,7 +5,7 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Language.Haskell.TH as TH import qualified Happy.Backend.CodeCombinators.Syntax as SnGen -import qualified Happy.Backend.CodeCombinators.Abstract as AbsGen +import qualified Happy.Backend.CodeCombinators.Abstract() import Happy.Backend.CodeCombinators import Test.CodeCombinators.Common import Data.List diff --git a/packages/code-combinators/test/Test/CodeCombinators/GenType.hs b/packages/code-combinators/test/Test/CodeCombinators/GenType.hs index 49b26e85..a4286719 100644 --- a/packages/code-combinators/test/Test/CodeCombinators/GenType.hs +++ b/packages/code-combinators/test/Test/CodeCombinators/GenType.hs @@ -5,10 +5,9 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Language.Haskell.TH as TH import qualified Happy.Backend.CodeCombinators.Syntax as SnGen -import qualified Happy.Backend.CodeCombinators.Abstract as AbsGen +import qualified Happy.Backend.CodeCombinators.Abstract() import Happy.Backend.CodeCombinators import Test.CodeCombinators.Common -import Data.List genIntT :: MonadGen m => m TH.Type genIntT = return $ intT From 650e74cc321618982234fe39e9f35afe13e86399 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 18:53:18 +0300 Subject: [PATCH 35/39] Add noInlinePragma generating function to CodeCombinators --- .../code-combinators/src/Happy/Backend/CodeCombinators.hs | 1 + .../src/Happy/Backend/CodeCombinators/Abstract.hs | 7 ++++++- .../src/Happy/Backend/CodeCombinators/Syntax.hs | 5 +++++ 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs index c824f53c..977c8323 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators.hs @@ -47,6 +47,7 @@ class (IsString (NameT e), Monad (NewNameM e)) => CodeGen e where sigD :: NameT e -> TypeT e -> DecT e funD :: NameT e -> [ClauseT e] -> DecT e + noInlinePragmaD :: NameT e -> DecT e trueE :: CodeGen e => e diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs index 178a35f0..7740eb64 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Abstract.hs @@ -26,7 +26,7 @@ instance CodeGen TH.Exp where negateE :: TH.Exp -> TH.Exp negateE = TH.AppE (TH.VarE $ mkName "GHC.Num.negate") - intE :: Integral a => a -> TH.Exp + intE :: Int -> TH.Exp intE num | num < 0 = negateE absE | otherwise = absE @@ -107,5 +107,10 @@ instance CodeGen TH.Exp where funD :: TH.Name -> [TH.Clause] -> TH.Dec funD = TH.FunD + noInlinePragmaD :: TH.Name -> TH.Dec + noInlinePragmaD name = + TH.PragmaD $ + TH.InlineP name TH.NoInline TH.FunLike TH.AllPhases + instance IsString TH.Name where fromString = mkName diff --git a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs index 96df8c5f..71f31925 100644 --- a/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs +++ b/packages/code-combinators/src/Happy/Backend/CodeCombinators/Syntax.hs @@ -182,6 +182,11 @@ instance CodeGen DocExp where funD :: DocName -> [DocClause] -> DocDec funD (DocName name) cls = DocDec $ foldr1 (PP.$+$) [name PP.<+> cl | DocClause cl <- cls] + noInlinePragmaD :: DocName -> DocDec + noInlinePragmaD (DocName name) = + DocDec $ + PP.text "{-# NOINLINE" PP.<+> name PP.<+> PP.text "#-}" + instance IsString DocName where fromString = mkName From f18959ac44fdaee8be371238642261a1417b07d7 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Tue, 29 Mar 2022 19:09:51 +0300 Subject: [PATCH 36/39] Rewrite pragma inside produceExpListPerState with code-combinators --- .../backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 0aa23056..7406ffc6 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -610,9 +610,10 @@ machinery to discard states in the parser... % f (Prelude.True, nr) = [token_strs Prelude.!! nr] > produceExpListPerState -> = renderDocDecs (runIdentity $ evalStateT (produceExpListArray @DocExp) Map.empty) -> . str "{-# NOINLINE happyExpListPerState #-}\n" -> . renderDocDecs [[happy_exp_list_per_state_dec]] +> = +> (renderDocDecs $ +> (runIdentity $ evalStateT (produceExpListArray @DocExp) Map.empty) +> ++ [[noInlinePragmaD happy_exp_list_per_state_name, happy_exp_list_per_state_dec]]) > . nl > where (first_token, last_token) = bounds token_names' > nr_tokens = last_token - first_token + 1 From 500a0457e2f132b7f48d18d05611acec72361327 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Sat, 16 Apr 2022 16:05:14 +0300 Subject: [PATCH 37/39] Remove redundant where section --- .../backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 7406ffc6..6cafe8fb 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -588,14 +588,12 @@ machinery to discard states in the parser... > = produceActionArray > . produceReduceArray > . renderDocDecs [ -> fullFunD happy_n_terms_name intT +> fullFunD "happy_n_terms" intT > [clause [] (intE n_terminals) []] -> , fullFunD happy_n_nonterms_name intT +> , fullFunD "happy_n_nonterms_name" intT > [clause [] (intE n_nonterminals) []] > ] > . nl -> where happy_n_terms_name = "happy_n_terms" -> happy_n_nonterms_name = "happy_n_nonterms_name" % {-# NOINLINE happyExpListPerState #-} % happyExpListPerState st = token_strs_expected From a11071cf26d1f328a1e42bec16122aedefaf2fac Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Sat, 16 Apr 2022 16:23:35 +0300 Subject: [PATCH 38/39] Rewrite produceExpListArray without using newName generating --- .../backend-lalr/happy-backend-lalr.cabal | 2 +- .../src/Happy/Backend/LALR/ProduceCode.lhs | 39 +++++++------------ 2 files changed, 15 insertions(+), 26 deletions(-) diff --git a/packages/backend-lalr/happy-backend-lalr.cabal b/packages/backend-lalr/happy-backend-lalr.cabal index 01780c56..ebeaa9cf 100644 --- a/packages/backend-lalr/happy-backend-lalr.cabal +++ b/packages/backend-lalr/happy-backend-lalr.cabal @@ -55,6 +55,6 @@ library happy-code-combinators == 1.21.0 default-language: Haskell98 - default-extensions: CPP, MagicHash, FlexibleContexts, TypeApplications, OverloadedStrings + default-extensions: CPP, MagicHash, FlexibleContexts, OverloadedStrings ghc-options: -Wall other-modules: Paths_happy_backend_lalr diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 6cafe8fb..ae7e833c 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -27,9 +27,6 @@ The code generator. > import Happy.Backend.CodeCombinators > import Happy.Backend.CodeCombinators.Syntax -> import Control.Monad.State ( evalStateT ) -> import Control.Monad.Identity ( runIdentity ) -> import qualified Data.Map as Map %----------------------------------------------------------------------------- Produce the complete output file. @@ -609,9 +606,8 @@ machinery to discard states in the parser... > produceExpListPerState > = -> (renderDocDecs $ -> (runIdentity $ evalStateT (produceExpListArray @DocExp) Map.empty) -> ++ [[noInlinePragmaD happy_exp_list_per_state_name, happy_exp_list_per_state_dec]]) +> produceExpListArray +> . renderDocDecs [[noInlinePragmaD happy_exp_list_per_state_name, happy_exp_list_per_state_dec]] > . nl > where (first_token, last_token) = bounds token_names' > nr_tokens = last_token - first_token + 1 @@ -833,45 +829,38 @@ action array indexed by (terminal * last_state) + state > . interleave' "," (map shows table) > . str "\n\t])\n\n" -> produceExpListArray :: CodeGen e => NameContext e [[DecT e]] > produceExpListArray > | ghc > = > -- happyExpList :: HappyAddr > -- happyExpList = HappyA# "hexCharsE explist"# -> do -> happy_exp_list_name <- getName "happyExpList" -> happy_addr_name <- getName "HappyAddr" -> happy_addr_con_name <- getName "HappyA#" > let happy_exp_list_exp = -> appE (conE happy_addr_con_name) (hexCharsE explist) -> let happy_exp_list_dec = -> fullFunD happy_exp_list_name (conT happy_addr_name) +> appE (conE "HappyA#") (hexCharsE explist) +> happy_exp_list_dec = +> fullFunD "happyExpList" (conT "HappyAddr") > [(clause [] happy_exp_list_exp [])] -> return [happy_exp_list_dec] +> in +> renderDocDecs [happy_exp_list_dec] > | otherwise > = > -- happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int > -- happyExpList = Happy_Data_Array.listArray (0, table_size) [explist] -> do -> happy_exp_list_name <- getName "happyExpList" -> let data_array_name = "Happy_Data_Array.Array" -> let list_array_name = "Happy_Data_Array.listArray" > let happy_exp_list_type = > appManyArgsT -> (conT data_array_name) +> (conT "Happy_Data_Array.Array") > [intT, intT] -> let happy_exp_list_exp = +> happy_exp_list_exp = > appManyArgsE -> (varE list_array_name) +> (varE "Happy_Data_Array.listArray") > [ > tupE [intE 0, intE table_size] > , listE $ intE <$> explist > ] -> let happy_exp_list_dec = -> fullFunD happy_exp_list_name happy_exp_list_type +> happy_exp_list_dec = +> fullFunD "happyExpList" happy_exp_list_type > [(clause [] happy_exp_list_exp [])] -> return [happy_exp_list_dec] +> in +> renderDocDecs [happy_exp_list_dec] > (_, last_state) = bounds action > n_states = last_state + 1 From 6cae39df5385356d9a9b1594c2e615a5804a7553 Mon Sep 17 00:00:00 2001 From: Artem Zakharenko Date: Sat, 16 Apr 2022 16:27:39 +0300 Subject: [PATCH 39/39] Remove redundant comment --- .../src/Happy/Backend/LALR/ProduceCode.lhs | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index ae7e833c..b5cfeed2 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs @@ -592,18 +592,6 @@ machinery to discard states in the parser... > ] > . nl -% {-# NOINLINE happyExpListPerState #-} -% happyExpListPerState st = token_strs_expected -% where token_strs = " . str (show $ elems token_names') -% bit_start = st Prelude.* " . str (show nr_tokens) -% bit_end = (st Prelude.+ 1) Prelude.* " . str (show nr_tokens) -% read_bit = readArrayBit happyExpList -% bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] -% bits_indexed = Prelude.zip bits [0..nr_tokens - 1] -% token_strs_expected = Prelude.concatMap f bits_indexed -% f (Prelude.False, _) = [] -% f (Prelude.True, nr) = [token_strs Prelude.!! nr] - > produceExpListPerState > = > produceExpListArray