From 7808875273ce84cc8804965f34f6e23fee13292c Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Tue, 18 May 2021 07:37:41 +0200 Subject: [PATCH] [ #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 | 10 +- source/src/BNFC/Backend/C/CFtoCAbs.hs | 17 ++- source/src/BNFC/Backend/CPP/Common.hs | 18 ++- source/src/BNFC/Backend/Common/OOAbstract.hs | 2 +- .../src/BNFC/Backend/Haskell/CFtoAbstract.hs | 11 +- .../Backend/HaskellGADT/CFtoAbstractGADT.hs | 2 +- source/src/BNFC/Backend/Java/CFtoJavaAbs15.hs | 21 +-- source/src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs | 13 +- source/src/BNFC/Backend/OCaml/CFtoOCamlLex.hs | 22 +-- source/src/BNFC/CF.hs | 143 ++++++------------ source/src/BNFC/GetCF.hs | 23 ++- source/src/BNFC/TypeChecker.hs | 48 +++--- 12 files changed, 147 insertions(+), 183 deletions(-) diff --git a/source/src/BNFC/Backend/Agda.hs b/source/src/BNFC/Backend/Agda.hs index cd914219..4ef831eb 100644 --- a/source/src/BNFC/Backend/Agda.hs +++ b/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 diff --git a/source/src/BNFC/Backend/C/CFtoCAbs.hs b/source/src/BNFC/Backend/C/CFtoCAbs.hs index 0b0aa0e0..02a86067 100644 --- a/source/src/BNFC/Backend/C/CFtoCAbs.hs +++ b/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 diff --git a/source/src/BNFC/Backend/CPP/Common.hs b/source/src/BNFC/Backend/CPP/Common.hs index d856e12b..5de2f7b4 100644 --- a/source/src/BNFC/Backend/CPP/Common.hs +++ b/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 diff --git a/source/src/BNFC/Backend/Common/OOAbstract.hs b/source/src/BNFC/Backend/Common/OOAbstract.hs index fbf8700e..f42acb69 100644 --- a/source/src/BNFC/Backend/Common/OOAbstract.hs +++ b/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 = diff --git a/source/src/BNFC/Backend/Haskell/CFtoAbstract.hs b/source/src/BNFC/Backend/Haskell/CFtoAbstract.hs index ee7f1885..8a36e83b 100644 --- a/source/src/BNFC/Backend/Haskell/CFtoAbstract.hs +++ b/source/src/BNFC/Backend/Haskell/CFtoAbstract.hs @@ -293,9 +293,9 @@ 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 ] @@ -303,14 +303,15 @@ definedRules functor cf = [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ] ] 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 diff --git a/source/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs b/source/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs index 13918d1f..0a6dd9fb 100644 --- a/source/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs +++ b/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 diff --git a/source/src/BNFC/Backend/Java/CFtoJavaAbs15.hs b/source/src/BNFC/Backend/Java/CFtoJavaAbs15.hs index ae6bcaf8..0290494d 100644 --- a/source/src/BNFC/Backend/Java/CFtoJavaAbs15.hs +++ b/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 diff --git a/source/src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs b/source/src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs index def90b72..7c09721c 100644 --- a/source/src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs +++ b/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 : "\'" diff --git a/source/src/BNFC/Backend/OCaml/CFtoOCamlLex.hs b/source/src/BNFC/Backend/OCaml/CFtoOCamlLex.hs index b0a3e127..9cb16eb1 100644 --- a/source/src/BNFC/Backend/OCaml/CFtoOCamlLex.hs +++ b/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] diff --git a/source/src/BNFC/CF.hs b/source/src/BNFC/CF.hs index bfbde2e8..9a96c568 100644 --- a/source/src/BNFC/CF.hs +++ b/source/src/BNFC/CF.hs @@ -9,87 +9,10 @@ {- BNF Converter: Abstract syntax Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer, Aarne Ranta - + Copyright (C) 2017-2021 Andreas Abel -} -module BNFC.CF ( - -- Types. - CF, - CFG(..), - Rule, Rul(..), npRule, valCat, lookupRule, InternalRule(..), - Pragma(..), - Exp, Exp'(..), - Base(..), Type(..), Signature, - Literal, - Symbol, - KeyWord, - LayoutKeyWords, Delimiters(..), - Position(..), noPosition, prettyPosition, npIdentifier, - WithPosition(..), blendInPosition, - RString, RCat, - Cat(..), strToCat, catToStr, - BaseCat, TokenCat, - catString, catInteger, catDouble, catChar, catIdent, - NonTerminal, SentForm, - Fun, RFun, IsFun(..), - Data, -- describes the abstract syntax of a grammar - cf2data, -- translates a grammar to a Data object. - cf2dataLists, -- translates to a Data with List categories included. - getAbstractSyntax, - -- Literal categories, constants, - firstEntry, -- the first entry or the first value category - baseTokenCatNames, -- "Char", "Double", "Integer", "String" - specialCats, -- ident - specialCatsP, -- all literals - specialData, -- special data - isDefinedRule, -- defined rules (allows syntactic sugar) - isProperLabel, -- not coercion or defined rule - allCats, -- all categories of a grammar - allParserCats, allParserCatsNorm, - reallyAllCats, - allCatsNorm, - allCatsIdNorm, - allEntryPoints, - reservedWords, - cfTokens, - literals, - findAllReversibleCats, -- find all reversible categories - identCat, -- transforms '[C]' to ListC (others, unchanged). - isParsable, - rulesForCat, -- rules for a given category - rulesForNormalizedCat, -- rules for a given category - ruleGroups, -- Categories are grouped with their rules. - ruleGroupsInternals, --As above, but includes internal cats. - allNames, -- Checking for non-unique names, like @Name. Name ::= Ident;@. - filterNonUnique, - isList, -- Checks if a category is a list category. - isTokenCat, maybeTokenCat, - baseCat, - sameCat, - -- Information functions for list functions. - hasNilRule, hasSingletonRule, - sortRulesByPrecedence, - isNilCons, -- either three of above? - isEmptyListCat, -- checks if the list permits [] - revSepListRule, -- reverse a rule, if it is of form C t [C]. - normCat, - isDataCat, isDataOrListCat, - normCatOfList, -- Removes precendence information and enclosed List. C1 => C, C2 => C - catOfList, - comments, -- translates the pragmas into two list containing the s./m. comments - numberOfBlockCommentForms, - tokenPragmas, -- get the user-defined regular expression tokens - tokenNames, -- get the names of all user-defined tokens - precCat, -- get the precendence level of a Cat C1 => 1, C => 0 - precRule, -- get the precendence level of the value category of a rule. - isUsedCat, - isPositionCat, - hasPositionTokens, - hasIdent, hasIdentLikeTokens, - hasLayout, hasLayout_, - layoutPragmas, - sigLookup -- Get the type of a rule label. - ) where +module BNFC.CF where import Prelude hiding ((<>)) @@ -197,6 +120,14 @@ data Base = BaseT String data Type = FunT [Base] Base deriving (Eq, Ord) +-- | Placeholder for a type. +dummyBase :: Base +dummyBase = BaseT "" + +-- | Placeholder for a function type. +dummyType :: Type +dummyType = FunT [] dummyBase + instance Show Base where show (BaseT x) = x show (ListT t) = "[" ++ show t ++ "]" @@ -207,8 +138,9 @@ instance Show Type where -- | Expressions for function definitions. data Exp' f - = App f [Exp' f] -- ^ (Possibly defined) label applied to expressions. - | Var String -- ^ Function parameter. + = App f Type [Exp' f] -- ^ (Possibly defined) label applied to expressions. + -- The function 'Type' is inferred by the type checker. + | Var String -- ^ Function parameter. | LitInt Integer | LitDouble Double | LitChar Char @@ -222,18 +154,18 @@ instance (IsFun f, Pretty f) => Pretty (Exp' f) where case listView e of Right es -> brackets $ hcat $ punctuate ", " $ map (prettyPrec 0) es Left (Var x) -> text x - Left (App f []) -> prettyPrec p f - Left (App f [e1,e2]) + Left (App f _ []) -> prettyPrec p f + Left (App f _ [e1,e2]) | isConsFun f -> parensIf (p > 0) $ hsep [ prettyPrec 1 e1, ":", prettyPrec 0 e2 ] - Left (App f es) -> parensIf (p > 1) $ hsep $ prettyPrec 1 f : map (prettyPrec 2) es + Left (App f _ es) -> parensIf (p > 1) $ hsep $ prettyPrec 1 f : map (prettyPrec 2) es Left (LitInt n) -> (text . show) n Left (LitDouble x) -> (text . show) x Left (LitChar c) -> (text . show) c Left (LitString s) -> (text . show) s where - listView (App f []) + listView (App f _ []) | isNilFun f = Right [] - listView (App f [e1,e2]) + listView (App f _ [e1,e2]) | isConsFun f , Right es <- listView e2 = Right $ e1:es listView e0 = Left e0 @@ -248,7 +180,31 @@ data Pragma | Layout LayoutKeyWords | LayoutStop [KeyWord] | LayoutTop Symbol -- ^ Separator for top-level layout. - | FunDef RFun [String] Exp + | FunDef Define + +data Define = Define + { defName :: RFun + , defArgs :: Telescope -- ^ Argument types inferred by the type checker. + , defBody :: Exp + , defType :: Base -- ^ Type of the body, inferred by the type checker. + } + +-- | Function arguments with type. +type Telescope = [(String, Base)] + +-- | For use with 'partitionEithers'. +isFunDef :: Pragma -> Either Pragma Define +isFunDef = \case + FunDef d -> Right d + p -> Left p + +-- | All 'define' pragmas of the grammar. +definitions :: CFG f -> [Define] +definitions cf = [ def | FunDef def <- cfgPragmas cf ] + +------------------------------------------------------------------------------ +-- Layout +------------------------------------------------------------------------------ type LayoutKeyWords = [(KeyWord, Delimiters)] @@ -418,6 +374,7 @@ catIdent = "Ident" baseTokenCatNames :: [TokenCat] baseTokenCatNames = [ catChar, catDouble, catInteger, catString ] +-- all literals -- the parser needs these specialCatsP :: [TokenCat] specialCatsP = catIdent : baseTokenCatNames @@ -440,10 +397,7 @@ isDataOrListCat _ = True -- True sameCat :: Cat -> Cat -> Bool -sameCat (CoercCat c1 _) (CoercCat c2 _) = c1 == c2 -sameCat (Cat c1) (CoercCat c2 _) = c1 == c2 -sameCat (CoercCat c1 _) (Cat c2) = c1 == c2 -sameCat c1 c2 = c1 == c2 +sameCat = (==) `on` normCat -- | Removes precedence information. C1 => C, [C2] => [C] normCat :: Cat -> Cat @@ -536,6 +490,7 @@ isDefinedRule = funNameSatisfies $ \case (x:_) -> isLower x [] -> error "isDefinedRule: empty function name" +-- not coercion or defined rule isProperLabel :: IsFun a => a -> Bool isProperLabel f = not (isCoercion f || isDefinedRule f) @@ -718,14 +673,16 @@ cf2data' predicate cf = [(cat, nub (map mkData [r | r <- cfgRules cf, let f = funRule r, not (isDefinedRule f), - not (isCoercion f), sameCat cat (valCat r)])) + not (isCoercion f), cat == normCat (valCat r)])) | cat <- nub $ map normCat $ filter predicate $ reallyAllCats cf ] - where + where mkData (Rule f _ its _) = (wpThing f, [normCat c | Left c <- its ]) +-- translates a grammar to a Data object. cf2data :: CF -> [Data] cf2data = cf2data' $ isDataCat . normCat +-- translates to a Data with List categories included. cf2dataLists :: CF -> [Data] cf2dataLists = cf2data' $ isDataOrListCat . normCat diff --git a/source/src/BNFC/GetCF.hs b/source/src/BNFC/GetCF.hs index 02ff6419..d108c854 100644 --- a/source/src/BNFC/GetCF.hs +++ b/source/src/BNFC/GetCF.hs @@ -71,7 +71,9 @@ parseCF opts target content = do >>= return . expandRules >>= getCF opts >>= return . markTokenCategories - either dieUnlessForce return $ runTypeChecker $ checkDefinitions cf + + -- Construct the typing information in 'define' expressions. + cf <- either die return $ runTypeChecker $ checkDefinitions cf -- Some backends do not allow the grammar name to coincide with -- one of the category or constructor names. @@ -184,10 +186,7 @@ parseCF opts target content = do ] -- Fail if the grammar uses defined constructors which are not actually defined. - let definedConstructor = \case - FunDef x _ _ -> Just x - _ -> Nothing - let definedConstructors = Set.fromList $ mapMaybe definedConstructor $ cfgPragmas cf + let definedConstructors = Set.fromList $ map defName $ definitions cf let undefinedConstructor x = isDefinedRule x && x `Set.notMember` definedConstructors case filter undefinedConstructor $ map funRule $ cfgRules cf of [] -> return () @@ -381,7 +380,7 @@ transDef = \case Abs.Function ident xs e -> do f <- transIdent ident let xs' = map transArg xs - return [ Left $ FunDef f xs' $ transExp xs' e ] + return [ Left $ FunDef $ Define f xs' (transExp (map fst xs') e) dummyBase ] -- | Translate @separator [nonempty] C "s"@. -- The position attached to the generated rules is taken from @C@. @@ -502,8 +501,8 @@ transIdent (Abs.Identifier ((line, col), str)) = do file <- asks lbnfFile return $ WithPosition (Position file line col) str -transArg :: Abs.Arg -> String -transArg (Abs.Arg (Abs.Identifier (_pos, x))) = x +transArg :: Abs.Arg -> (String, Base) +transArg (Abs.Arg (Abs.Identifier (_pos, x))) = (x, dummyBase) transExp :: [String] -- ^ Arguments of definition (in scope in expression). @@ -512,17 +511,17 @@ transExp transExp xs = loop where loop = \case - Abs.App x es -> App (transIdent' x) (map loop es) + Abs.App x es -> App (transIdent' x) dummyType (map loop es) Abs.Var x -> let x' = transIdent' x in - if x' `elem` xs then Var x' else App x' [] + if x' `elem` xs then Var x' else App x' dummyType [] Abs.Cons e1 e2 -> cons e1 (loop e2) Abs.List es -> foldr cons nil es Abs.LitInt x -> LitInt x Abs.LitDouble x -> LitDouble x Abs.LitChar x -> LitChar x Abs.LitString x -> LitString x - cons e1 e2 = App "(:)" [loop e1, e2] - nil = App "[]" [] + cons e1 e2 = App "(:)" dummyType [loop e1, e2] + nil = App "[]" dummyType [] transIdent' (Abs.Identifier (_pos, x)) = x -------------------------------------------------------------------------------- diff --git a/source/src/BNFC/TypeChecker.hs b/source/src/BNFC/TypeChecker.hs index 3d7a50ba..deb399f1 100644 --- a/source/src/BNFC/TypeChecker.hs +++ b/source/src/BNFC/TypeChecker.hs @@ -16,7 +16,7 @@ module BNFC.TypeChecker -- * Backdoor for rechecking defined syntax constructors for list types , checkDefinition' , buildSignature, buildContext, ctxTokens, isToken - , ListConstructors(LC) + , ListConstructors(..) ) where import Control.Monad @@ -25,6 +25,7 @@ import Control.Monad.Reader import Data.Bifunctor import Data.Char +import Data.Either (partitionEithers) import qualified Data.Map as Map import qualified Data.Set as Set @@ -55,9 +56,6 @@ runTypeChecker m = first blendInPosition $ unErr m `runReaderT` NoPosition -- * Types and context --- | Function arguments with type. -type Telescope = [(String, Base)] - data Context = Ctx { ctxLabels :: Signature -- ^ Types of labels, extracted from rules. , ctxTokens :: [String] -- ^ User-defined token types. @@ -65,25 +63,31 @@ data Context = Ctx } data ListConstructors = LC - { nil :: Base -> String - , cons :: Base -> String - } + { nil :: Base -> (String, Type) -- ^ 'Base' is the element type. 'Type' the list type. + , cons :: Base -> (String, Type) + } dummyConstructors :: ListConstructors -dummyConstructors = LC (const "[]") (const "(:)") - +dummyConstructors = LC + { nil = \ b -> ("[]" , FunT [] (ListT b)) + , cons = \ b -> ("(:)", FunT [b, ListT b] (ListT b)) + } -- * Type checker for definitions and expressions -- | Entry point. -checkDefinitions :: CF -> Err () +checkDefinitions :: CF -> Err CF checkDefinitions cf = do let ctx = buildContext cf - sequence_ [ checkDefinition ctx f xs e | FunDef f xs e <- cfgPragmas cf ] + let (pragmas, defs0) = partitionEithers $ map isFunDef $ cfgPragmas cf + defs <- mapM (checkDefinition ctx) defs0 + return cf { cfgPragmas = pragmas ++ map FunDef defs } -checkDefinition :: Context -> RFun -> [String] -> Exp -> Err () -checkDefinition ctx f xs e = - void $ checkDefinition' dummyConstructors ctx f xs e +checkDefinition :: Context -> Define -> Err Define +checkDefinition ctx (Define f args e0 _) = do + let xs = map fst args -- Throw away dummy types. + (tel, (e, b)) <- checkDefinition' dummyConstructors ctx f xs e0 + return $ Define f tel e b checkDefinition' :: ListConstructors -- ^ Translation of the list constructors. @@ -115,19 +119,19 @@ checkDefinition' list ctx ident xs e = checkExp :: ListConstructors -> Context -> Exp -> Base -> Err Exp checkExp list ctx = curry $ \case - (App "[]" [] , ListT t ) -> return (App (nil list t) []) - (App "[]" _ , _ ) -> throwError $ + (App "[]" _ [] , ListT t ) -> return (uncurry App (nil list t) []) + (App "[]" _ _ , _ ) -> throwError $ "[] is applied to too many arguments." - (App "(:)" [e,es], ListT t ) -> do + (App "(:)" _ [e,es], ListT t ) -> do e' <- checkExp list ctx e t es' <- checkExp list ctx es (ListT t) - return $ App (cons list t) [e',es'] + return $ uncurry App (cons list t) [e',es'] - (App "(:)" es , _ ) -> throwError $ + (App "(:)" _ es , _ ) -> throwError $ "(:) takes 2 arguments, but has been given " ++ show (length es) ++ "." - (e@(App x es) , t ) -> checkApp e x es t + (e@(App x _ es) , t ) -> checkApp e x es t (e@(Var x) , t ) -> e <$ checkApp e x [] t (e@LitInt{} , BaseT "Integer") -> return e (e@LitDouble{} , BaseT "Double" ) -> return e @@ -137,10 +141,10 @@ checkExp list ctx = curry $ \case prettyShow e ++ " does not have type " ++ show t ++ "." where checkApp e x es t = do - FunT ts t' <- lookupCtx x ctx + ft@(FunT ts t') <- lookupCtx x ctx es' <- matchArgs ts unless (t == t') $ throwError $ prettyShow e ++ " has type " ++ show t' ++ ", but something of type " ++ show t ++ " was expected." - return $ App x es' + return $ App x ft es' where matchArgs ts | expect /= given = throwError $ "'" ++ x ++ "' takes " ++ show expect ++ " arguments, but has been given " ++ show given ++ "."