[ #363 refactor ] retain typing information constructed by TypeChecker

Typing information is preserved in Exp and the Define pragma.

Not used yet in the backends.

source/src/BNFC/Backend/Agda.hs

@@ -143,8 +143,6 @@ import BNFC.Options                (SharedOptions, TokenText(..), tokenText)
 import BNFC.PrettyPrint
 import BNFC.Utils                  (ModuleName, replace, when, table)
 
-type List1 = List1.NonEmpty
-
 -- | How to print the types of constructors in Agda?
 
 data ConstructorStyle
@@ -649,21 +647,21 @@ incr = Map.alter $ maybe (Just 1) (Just . succ)
 
 -- | Generate Haskell code for the @define@d constructors.
 definedRules :: CF -> Doc
-definedRules cf = vsep [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]
+definedRules cf = vsep $ map mkDef $ definitions cf
   where
-    mkDef f xs e = vcat $ concat
+    mkDef (Define f args e t) = vcat $ concat
       [ [ text $ unwords [ mkDefName f, ":", typeToHaskell' "→" $ wpThing t ]
         | t <- maybeToList $ sigLookup f cf
         ]
       , [ sep $ concat
           [ [ text (mkDefName f), "=", "λ" ]
-          , map (text . agdaLower) xs
+          , map (text . agdaLower . fst) args
           , [ "→", pretty $ sanitize e ]
           ]
         ]
       ]
     sanitize = \case
-      App x es      -> App (agdaLower x) $ map sanitize es
+      App x t es    -> App (agdaLower x) t $ map sanitize es
       Var x         -> Var $ agdaLower x
       e@LitInt{}    -> e
       e@LitDouble{} -> e

source/src/BNFC/Backend/C/CFtoCAbs.hs

@@ -75,7 +75,7 @@ mkHFile rp classes datas cf = unlines $ concat
     [ "/********************   Defined Constructors    ***********************/"
     , ""
     ]
-  , map (uncurry3 (prDefH user)) definedConstructors
+  , map (prDefH user) definedConstructors
 
   , [ ""
     , "#endif"
@@ -91,7 +91,7 @@ mkHFile rp classes datas cf = unlines $ concat
     ]
   prFreeH :: String -> String
   prFreeH s = "void free" ++ s ++ "(" ++ s ++ " p);"
-  definedConstructors = [ (funName f, xs, e) | FunDef f xs e <- cfgPragmas cf ]
+  definedConstructors = definitions cf
 
 destructorComment :: [String]
 destructorComment =
@@ -113,20 +113,21 @@ destructorComment =
 --
 prDefH
   :: [TokenCat] -- ^ Names of the token constructors (silent in C backend).
-  -> String     -- ^ Name of the defined constructor.
-  -> [String]   -- ^ Names of the arguments.
-  -> Exp        -- ^ Definition (referring to arguments and rule labels).
+  -> Define
   -> String
-prDefH tokenCats f xs e = concat [ "#define make_", f, "(", intercalate "," xs, ") ", prExp e ]
+prDefH tokenCats (Define fun args e t) =
+  concat [ "#define make_", f, "(", intercalate "," xs, ") ", prExp e ]
   where
+  f  = funName fun
+  xs = map fst args
   prExp :: Exp -> String
   prExp = \case
     Var x       -> x
     -- Andreas, 2021-02-13, issue #338
     -- Token categories are just @typedef@s in C, so no constructor needed.
-    App g [e] | g `elem` tokenCats
+    App g _ [e] | g `elem` tokenCats
                 -> prExp e
-    App g es    -> concat [ "make_", g, "(", intercalate "," (map prExp es), ")" ]
+    App g _ es  -> concat [ "make_", g, "(", intercalate "," (map prExp es), ")" ]
     LitInt    i -> show i
     LitDouble d -> show d
     LitChar   c -> show c

source/src/BNFC/Backend/CPP/Common.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+
 -- | Common to the C++ backends.
 
 module BNFC.Backend.CPP.Common where
@@ -15,18 +17,21 @@ definedRules onlyHeader cf banner
   | null theLines = []
   | otherwise     = unlines $ banner : "" : theLines
   where
-    theLines = [ rule f xs e | FunDef f xs e <- cfgPragmas cf ]
+    theLines = map rule $ definitions cf
 
     ctx = buildContext cf
 
-    list = LC (const "[]") (\ t -> "List" ++ unBase t)
+    list = LC
+      { nil  =  const ("[]", dummyType)
+      , cons = \ t -> ("List" ++ unBase t, dummyType)
+      }
       where
         unBase (ListT t) = unBase t
         unBase (BaseT x) = norm x
 
     norm = catToStr . normCat . strToCat
 
-    rule f xs e =
+    rule (Define f args e t) =
       case runTypeChecker $ checkDefinition' list ctx f xs e of
         Left err -> error $ "Panic! This should have been caught already:\n" ++ err
         Right (args,(e',t))
@@ -40,6 +45,7 @@ definedRules onlyHeader cf banner
          header = cppType t ++ " " ++ funName f ++ "(" ++
                   intercalate ", " (map cppArg args) ++ ")"
       where
+        xs = map fst args
         cppType :: Base -> String
         cppType (ListT (BaseT x)) = "List" ++ norm x ++ "*"
         cppType (ListT t)         = cppType t ++ "*"
@@ -53,11 +59,11 @@ definedRules onlyHeader cf banner
 
         cppExp :: [String] -> Exp -> String
         cppExp args = \case
-            App "[]" []    -> "0"
+            App "[]" _ []    -> "0"
             Var x          -> x ++ "_"  -- argument
-            App t [e]
+            App t _ [e]
               | isToken t ctx    -> cppExp args e
-            App x es
+            App x _ es
               | isUpper (head x) -> call ("new " ++ x) es
               | x `elem` args    -> call (x ++ "_") es
               | otherwise        -> call x es

source/src/BNFC/Backend/Common/OOAbstract.hs

@@ -72,7 +72,7 @@ cf2cabs cf = CAbs
     [("Visitable",  -- to give superclass
      [(c,[("String",False,"string_"),("Integer",False,"integer_")])]) | c<-pos]
   status cat = (cat, notElem cat (map fst basetypes ++ toks))
-  defs = [ funName f | FunDef f _ _ <- cfgPragmas cf]
+  defs = [ funName f | FunDef (Define f _ _ _) <- cfgPragmas cf]
 
   classVars :: [(String,Bool)] -> [(String,Bool,String)]
   classVars cs =

source/src/BNFC/Backend/Haskell/CFtoAbstract.hs

@@ -293,24 +293,25 @@ instanceHasPositionTokenType cat = vcat
 
 -- | Generate Haskell code for the @define@d constructors.
 definedRules :: Bool -> CF -> [Doc]
-definedRules functor cf = [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]
+definedRules functor cf = map mkDef $ definitions cf
   where
-  mkDef f xs e = vcat $ concat
+  mkDef (Define f args e t) = vcat $ concat
     [ [ text $ unwords [ fName, "::", typ $ wpThing t ]
       | t <- maybeToList $ sigLookup f cf
       ]
     , [ sep $ map text (fName : xs') ++ [ "=", pretty $ sanitize e ] ]
     ]
     where
     fName = mkDefName f
+    xs    = map fst args
     avoidReserved = avoidReservedWords [fName]
     xs' = addFunctorArg id $ map avoidReserved xs
     typ (FunT ts t) | functor = List.intercalate " -> " $ "a" : (map funBase $ ts ++ [t])
     typ t = typeToHaskell t
     sanitize = \case
-      App x es
-        | tokTyp x  -> App x $ map sanitize es
-        | otherwise -> App x $ addFunctorArg (`App` []) $ map sanitize es
+      App x t es
+        | tokTyp x  -> App x t $ map sanitize es
+        | otherwise -> App x t $ addFunctorArg (\ e -> App e dummyType []) $ map sanitize es
       Var x         -> Var $ avoidReserved x
       e@LitInt{}    -> e
       e@LitDouble{} -> e

source/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs

@@ -82,7 +82,7 @@ getTreeCats :: CF -> [String]
 getTreeCats cf = List.nub $ map catToStr $ filter (not . isList) $ map consCat $ cf2cons cf
 
 getDefinitions :: CF -> [String]
-getDefinitions cf = [ funName f | FunDef f _ _ <- cfgPragmas cf ]
+getDefinitions = map (funName . defName) . definitions
 
 prDummyTypes :: CF -> [String]
 prDummyTypes cf = prDummyData : map prDummyType cats

source/src/BNFC/Backend/Java/CFtoJavaAbs15.hs

@@ -62,7 +62,7 @@ cf2JavaAbs dirAbsyn packageBase packageAbsyn cf rp = concat
   header = "package " ++ packageAbsyn ++ "; // Java Package generated by the BNF Converter.\n"
   user   = [ n | (n,_) <- tokenPragmas cf ]
   rules  = getAbstractSyntax cf
-  defs   = [ (f, xs, e) | FunDef f xs e <- cfgPragmas cf ]
+  defs   = definitions cf
   deftext= concat
    [ [ "package " ++ packageBase ++ "; // Java Package generated by the BNF Converter."
      , ""
@@ -75,20 +75,23 @@ cf2JavaAbs dirAbsyn packageBase packageAbsyn cf rp = concat
   mkPath :: String -> FilePath
   mkPath s = dirAbsyn </> s
 
-definedRules :: [(RFun, [String], Exp)] -> String -> CF -> [String]
-definedRules defs packageAbsyn cf = map (uncurry3 rule) defs
+definedRules :: [Define] -> String -> CF -> [String]
+definedRules defs packageAbsyn cf = map rule defs
   where
     ctx = buildContext cf
 
-    list = LC (\ t -> "List" ++ unBase t) (const "cons")
+    list = LC
+      { nil  = \ t -> ("List" ++ unBase t, FunT [] (ListT t))
+      , cons = \ t -> ("cons", FunT [t, ListT t] (ListT t))
+      }
       where
          unBase (ListT t) = unBase t
          unBase (BaseT x) = norm x
 
     norm = catToStr . normCat . strToCat
 
-    rule f xs e =
-        case runTypeChecker $ checkDefinition' list ctx f xs e of
+    rule (Define f args e t) =
+        case runTypeChecker $ checkDefinition' list ctx f (map fst args) e of
             Left err ->
                 error $ "Panic! This should have been caught already:\n"
                     ++ err
@@ -112,11 +115,11 @@ definedRules defs packageAbsyn cf = map (uncurry3 rule) defs
 
        javaExp :: [String] -> Exp -> String
        javaExp args = \case
-           App "null" []        -> "null"
+           App "null" _ []        -> "null"
            Var x                -> x      -- argument
-           App t [e]
+           App t _ [e]
              | isToken t ctx    -> javaExp args e     -- wraps new String
-           App x es
+           App x _ es
              | isUpper (head x) -> call ("new " ++ packageAbsyn ++ "." ++ x) es
              | otherwise        -> call x es
              -- -- | x `elem` args    -> call x es

source/src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+
 {-
     BNF Converter: OCaml Abstract Syntax Generator
     Copyright (C) 2005  Author:  Kristofer Johannisson
@@ -36,16 +38,17 @@ cf2Abstract _ cf = unlines $ concat
   defs = definedRules cf
 
 definedRules :: CF -> [String]
-definedRules cf = [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]
+definedRules cf = map mkDef $ definitions cf
   where
-    mkDef f xs e = "let " ++ funName f ++ " " ++ mkTuple xs ++ " = " ++ ocamlExp False e
+    mkDef (Define f args e t) =
+      "let " ++ funName f ++ " " ++ mkTuple (map fst args) ++ " = " ++ ocamlExp False e
 
     ocamlExp :: Bool -> Exp -> String
     ocamlExp p = \case
       Var s       -> s
-      App s []    -> s
-      App s [e]   -> parensIf p $ s ++ ' ' : ocamlExp True e
-      App s es    -> parensIf p $ s ++ ' ' : mkTuple (map (ocamlExp False) es)
+      App s _ []  -> s
+      App s _ [e] -> parensIf p $ s ++ ' ' : ocamlExp True e
+      App s _ es  -> parensIf p $ s ++ ' ' : mkTuple (map (ocamlExp False) es)
       LitInt i    -> show i
       LitDouble d -> show d
       LitChar c   -> "\'" ++ c : "\'"

source/src/BNFC/Backend/OCaml/CFtoOCamlLex.hs

@@ -27,12 +27,13 @@ import BNFC.Lexing (mkRegMultilineComment)
 import BNFC.Utils (cstring, unless)
 
 cf2ocamllex :: String -> String -> CF -> String
-cf2ocamllex _ parserMod cf =
-  unlines $ List.intercalate [""] [
-    header parserMod cf,
-    definitions cf,
-    [PP.render (rules cf)]
-   ]
+cf2ocamllex _ parserMod cf = unlines $ List.intercalate [""]
+  [ header parserMod cf
+  , cMacros
+  , rMacros cf
+  , uMacros cf
+  , [ PP.render $ rules cf ]
+  ]
 
 header :: String -> CF -> [String]
 header parserMod cf = List.intercalate [""] . filter (not . null) $ concat
@@ -93,14 +94,6 @@ hashtables cf =
     where
     keyvals = map (\ s -> concat [ "(", mkEsc s, ", ", terminal cf s, ")" ]) syms
 
-
-definitions :: CF -> [String]
-definitions cf = concat $
-  [ cMacros
-  , rMacros cf
-  , uMacros cf
-  ]
-
 cMacros :: [String]
 cMacros =
   [ "(* BNFC character classes *)"
@@ -110,7 +103,6 @@ cMacros =
   , "let _digit  = ['0'-'9']                             (*  _digit *)"
   , "let _idchar = _letter | _digit | ['_' '\\'']         (*  identifier character *)"
   , "let _universal = _                                  (* universal: any character *)"
-  , ""
   ]
 
 rMacros :: CF -> [String]