BNFC-meta-0.1: Language/LBNF/GetCF.hs
{-
BNF Converter: Abstract syntax
Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module Language.LBNF.GetCF where
import Control.Monad ( when )
import Language.LBNF.CF
import Language.LBNF.Utils
import Language.LBNF.ParBNF
import Data.List(nub,partition)
import qualified Language.LBNF.AbsBNF as Abs
-- import LexBNF
import Language.LBNF.ErrM
import Data.Char
import Language.LBNF.TypeChecker
readCF :: FilePath -> IO CF
readCF f = tryReadCF f >>= return . fst
tryReadCF :: FilePath -> IO (CF,Bool)
tryReadCF file = do
(cfp,m) <- tryReadCFP file
return (cfp2cf cfp, m)
tryReadCFP :: FilePath -> IO (CFP,Bool)
tryReadCFP file = do
putStrLn $ "\nReading grammar from " ++ file
s <- readFile file
let (cfp,msg') = getCFP s
cf = cfp2cf cfp
msg = case checkDefinitions cf of
Bad err -> msg' ++ [err]
Ok () -> msg'
ret = cfp
if not (null msg) then do
putStrLn $ unlines msg
return (ret,False)
else do
putStrLn $ show (length (rulesOfCF cf)) +++ "rules accepted\n"
let c3s = [(b,e) | (b,e) <- fst (comments cf), length b > 2 || length e > 2]
if null c3s then return () else do
putStrLn
"Warning: comment delimiters longer than 2 characters ignored in Haskell:"
mapM_ putStrLn [b +++ "-" +++ e | (b,e) <- c3s]
case filter (not . isDefinedRule) $ notUniqueFuns cf of
[] -> case (badInheritence cf) of
[] -> return (ret,True)
xs -> do
putStrLn "Warning :"
putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs
putStrLn $ " These categories have more than one Label, yet one of these"
putStrLn $ " Labels has the same name as the Category. This will almost"
putStrLn $ " certainly cause problems in languages other than Haskell.\n"
return (ret,True)
xs -> do
putStrLn $ "Warning :"
putStrLn $ " Non-unique label name(s) : " ++ unwords xs
putStrLn $ " There may be problems with the pretty-printer.\n"
case (badInheritence cf) of
[] -> return (ret,True)
xs -> do
putStrLn $ "Warning :"
putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs
putStrLn $ " These categories have more than one Label, yet one of these"
putStrLn $ " Labels has the same name as the Category. This will almost"
putStrLn $ " certainly cause problems in languages other than Haskell.\n"
return (ret,True)
-- peteg: FIXME this is racey.
-- want to be a bit smarter about whether we actually generate the file
-- or save it... e.g. ErrM.hs need not be regenerated if it exists.
getCF :: String -> (CF, [String])
getCF s = let (cfp,msg) = getCFP s in (cfp2cf cfp, msg)
getCFP :: String -> (CFP, [String])
getCFP s = (cf,msgs ++ msgs1) where
(cf,msgs1) = ((exts,ruls2),msgs2)
(ruls2,msgs2) = untag $ partition (isRule) $ map (checkRule cf00) $ rulesOfCFP cf0
untag (ls,rs) = ([c | Left c <- ls], [c | Right c <- rs])
isRule = either (const True) (const False)
cf00 = cfp2cf cf0
(cf0@(exts,_),msgs) = (revs . srt . conv . pGrammar . myLexer) s
srt rs = let rules = [r | Left (Right r) <- rs]
literals = nub [lit | xs <- map (snd . snd) rules,
(Left lit) <- xs,
elem lit specialCatsP]
pragma = [r | Left (Left r) <- rs]
errors = [s | Right s <- rs, not (null s)]
(symbols,keywords) = partition notIdent reservedWords
notIdent s = null s || not (isAlpha (head s)) || any (not . isIdentRest) s
isIdentRest c = isAlphaNum c || c == '_' || c == '\''
reservedWords = nub [t | (_,(_,its)) <- rules, Right t <- its]
cats = []
in (((pragma,(literals,symbols,keywords,cats)),rules),errors)
revs (cf@((pragma,(literals,symbols,keywords,_)),rules),errors) =
(((pragma,
(literals,symbols,keywords,findAllReversibleCats (cfp2cf cf))),rules),errors)
conv :: Err Abs.Grammar -> [Either (Either Pragma RuleP) String]
conv (Bad s) = [Right s]
conv (Ok (Abs.Grammar defs)) = map Left $ concatMap (transDef defs) defs
transDef :: [Abs.Def] -> Abs.Def -> [Either Pragma RuleP]
transDef defs x = case x of
Abs.Rule label cat items ->
[Right (transLabel label,(transCat cat,map transItem items))]
Abs.Comment str -> [Left $ CommentS str]
Abs.Comments str0 str -> [Left $ CommentM (str0,str)]
Abs.Token ident reg -> [Left $ TokenReg (transIdent ident) False reg]
Abs.PosToken ident reg -> [Left $ TokenReg (transIdent ident) True reg]
Abs.Entryp idents -> [Left $ EntryPoints (map transIdent idents)]
Abs.Internal label cat items ->
[Right (transLabel label,(transCat cat,(Left "#":(map transItem items))))]
Abs.Separator size ident str -> map (Right . cf2cfpRule) $ separatorRules size ident str
Abs.Terminator size ident str -> map (Right . cf2cfpRule) $ terminatorRules size ident str
Abs.Coercions ident int -> map (Right . cf2cfpRule) $ coercionRules ident int
Abs.Rules ident strs -> map (Right . cf2cfpRule) $ ebnfRules ident strs
Abs.Layout ss -> [Left $ Layout ss]
Abs.LayoutStop ss -> [Left $ LayoutStop ss]
Abs.LayoutTop -> [Left $ LayoutTop]
-- Abs.Function f xs e -> [Left $ FunDef (transIdent f) (map transArg xs) (transExp e)]
Abs.AntiQuote b i a ->
[Left $ AntiQuote b i a]
++ [Left $ TokenReg "AqToken" False $ aqToken i a]
++ nub (concatMap (aqDefs (b,i,a) (concatMap toks defs)) defs) where
reg = aqToken a
aqToken :: String -> String -> Abs.Reg
aqToken i s@(c:cs) = Abs.RSeq (Abs.RSeqs i) $ Abs.RSeq (Abs.RStar $ foldr1 Abs.RAlt $ map clause prefixes) $ Abs.RSeqs s where
prefixes = scanr (:) [c] . reverse $ cs
-- clause [d] = RMinus $ RAny $ RChar d
clause (d:ds) = subclause (reverse ds) (Abs.RMinus Abs.RAny $ Abs.RChar d)
subclause [] x = x
subclause (e:es) x = Abs.RSeq (Abs.RChar e) (subclause es x)
-- {":"} (((char - ']')':' | (char - ':')) * {":]"}
-- Abs.RSeq (Abs.RSeqs i) (go $ reverse cs) where
-- go [] = (Abs.RMinus Abs.RAny (Abs.RChar c))
-- go (d:ds) = Abs.RSeq (Abs.RStar $ go ds) (Abs.RChar d)
-- TokenReg "AqToken" False
-- (Abs.RSeq
-- (Abs.RSeq
-- (Abs.RSeqs i)
-- (Abs.RStar Abs.RAny))
-- (Abs.RSeqs a))
-- \begin{hack}
aqDefs :: (String,String,String) -> [String] -> Abs.Def -> [Either Pragma RuleP]
aqDefs ss tokens x = addSpecials ss $ concatMap (renamers ss tokens) $ case x of
Abs.Rule label cat items -> [Right (transLabel label,(transCat cat,map transItem items))]
-- case cat of
-- Abs.ListCat _ -> []
-- _ -> [Right (transLabel label,(transCat cat,map transItem items))]
Abs.Comment str -> []
Abs.Comments str0 str -> []
Abs.Token ident reg -> []
Abs.PosToken ident reg -> []
Abs.Entryp idents -> [Left $ EntryPoints (map transIdent idents)]
Abs.Internal label cat items ->
[Right (transLabel label,(transCat cat,(Left "#":(map transItem items))))]
Abs.Separator size ident str -> map (Right . cf2cfpRule) $ separatorRules size ident str
Abs.Terminator size ident str -> map (Right . cf2cfpRule) $ terminatorRules size ident str
Abs.Coercions ident int -> map (Right . cf2cfpRule) $ coercionRules ident int
Abs.Rules ident strs -> map (Right . cf2cfpRule) $ ebnfRules ident strs
Abs.Layout ss -> []
Abs.LayoutStop ss -> []
Abs.LayoutTop -> []
-- Abs.Function f xs e -> []
Abs.AntiQuote b i a -> []
toks x = case x of
Abs.Token (Abs.Ident ident) reg -> [ident]
Abs.PosToken (Abs.Ident ident) reg -> [ident]
_ -> []
renamers :: (String,String,String) -> [String] -> Either Pragma RuleP -> [Either Pragma RuleP]
renamers (b,i,a) tokens = either (return . Left . renamep) (map Right . renamer) where
renamep (EntryPoints eps) = EntryPoints $ map rename eps
renamer ((lab,(lab' ,p)),(cat,its)) = [
((rename lab,(rename lab' , p)),(rename cat, map renameItem its))
] ++ if isList cat then [] else [
cf2cfpRule (renameAq cat,(rename cat, [Right b,Left "AqToken"])),
cf2cfpRule (renameAqt cat,(rename cat, [Right (b++normCat cat), Left "AqToken"]))
]
renameItem = either (\s -> Left $ (if s `elem` tokens then id else rename) s) (Right . id)
addSpecials :: (String,String,String) -> [Either Pragma RuleP] -> [Either Pragma RuleP]
addSpecials (b,i,a) rs = rs ++ concatMap special literals where
special aqs@('A':'Q':'_':s) = map Right [cf2cfpRule $ (aqs,(aqs,[Left s])),
cf2cfpRule (renameAq s,(rename s, [Right b,Left "AqToken"])),
cf2cfpRule (renameAqt s,(rename s, [Right (b++s), Left "AqToken"]))
]
rules = [r | (Right r) <- rs]
literals = nub [lit | xs <- map (snd . snd) rules,
(Left lit) <- xs,
elem lit (map rename specialCatsP)]
-- \end{hack}
separatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule]
separatorRules size c s = if null s then terminatorRules size c s else ifEmpty [
("(:[])", (cs,[Left c'])),
("(:)", (cs,[Left c', Right s, Left cs]))
]
where
c' = transCat c
cs = "[" ++ c' ++ "]"
ifEmpty rs = if (size == Abs.MNonempty) then rs else (("[]", (cs,[])) : rs)
terminatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule]
terminatorRules size c s = [
ifEmpty,
("(:)", (cs,Left c' : s' [Left cs]))
]
where
c' = transCat c
cs = "[" ++ c' ++ "]"
s' its = if null s then its else (Right s : its)
ifEmpty = if (size == Abs.MNonempty)
then ("(:[])",(cs,[Left c'] ++ if null s then [] else [Right s]))
else ("[]", (cs,[]))
coercionRules :: Abs.Ident -> Integer -> [Rule]
coercionRules (Abs.Ident c) n =
("_", (c, [Left (c ++ "1")])) :
[("_", (c ++ show (i-1), [Left (c ++ show i)])) | i <- [2..n]] ++
[("_", (c ++ show n, [Right "(", Left c, Right ")"]))]
ebnfRules :: Abs.Ident -> [Abs.RHS] -> [Rule]
ebnfRules (Abs.Ident c) rhss =
[(mkFun k c its, (c, map transItem its)) | (k, Abs.RHS its) <- zip [1 :: Int ..] rhss]
where
mkFun k c i = case i of
[Abs.Terminal s] -> c' ++ "_" ++ mkName k s
[Abs.NTerminal n] -> c' ++ identCat (transCat n)
_ -> c' ++ "_" ++ show k
c' = c --- normCat c
mkName k s = if all (\c -> isAlphaNum c || elem c "_'") s
then s else show k
transItem :: Abs.Item -> Either Cat String
transItem x = case x of
Abs.Terminal str -> Right str
Abs.NTerminal cat -> Left (transCat cat)
transCat :: Abs.Cat -> Cat
transCat x = case x of
Abs.ListCat cat -> "[" ++ (transCat cat) ++ "]"
Abs.IdCat id -> transIdent id
transLabel :: Abs.Label -> (Fun,Prof)
transLabel y = case y of
Abs.LabNoP f -> let g = transLabelId f in (g,(g,[])) ---- should be Nothing
Abs.LabP f p -> let g = transLabelId f in (g,(g, map transProf p))
Abs.LabPF f g p -> (transLabelId f,(transLabelId g, map transProf p))
Abs.LabF f g -> (transLabelId f,(transLabelId g, []))
where
transLabelId x = case x of
Abs.Id id -> transIdent id
Abs.Wild -> "_"
Abs.ListE -> "[]"
Abs.ListCons -> "(:)"
Abs.ListOne -> "(:[])"
Abs.Aq -> "$"
transProf (Abs.ProfIt bss as) =
([map fromInteger bs | Abs.Ints bs <- bss], map fromInteger as)
transIdent :: Abs.Ident -> String
transIdent x = case x of
Abs.Ident str -> str
transArg :: Abs.Arg -> String
transArg (Abs.Arg x) = transIdent x
transExp :: Abs.Exp -> Exp
transExp e = case e of
Abs.App x es -> App (transIdent x) (map transExp es)
Abs.Var x -> App (transIdent x) []
Abs.Cons e1 e2 -> cons e1 (transExp 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
where
cons e1 e2 = App "(:)" [transExp e1, e2]
nil = App "[]" []