{-#Language PatternGuards#-}
module Language.LBNF.CF (
CF,
RHS,
Rule, funRule, isTokenRule,
Pragma(..),
Reg(..),
Exp(..),
Literal,
Symbol,
KeyWord,
Cat,
Fun,
Tree(..),
prTree,
Data,
cf2data,
firstCat,
firstEntry,
specialCats,
specialCatsP,
specialData,
isCoercion,
isDefinedRule,
isProperLabel,
allCats,
allCatsIdNorm,
allEntryPoints,
reservedWords,
symbols,
literals,
typed_literals,
reversibleCats,
findAllReversibleCats,
identCat,
valCat,
isParsable,
rulesOfCF,
rulesForCat,
ruleGroups,
ruleGroupsInternals,
notUniqueFuns,
badInheritence,
isList,
isNilFun,
isOneFun,
isConsFun,
isNilCons,
isEmptyListCat,
revSepListRule,
rhsRule,
normCat,
normCatOfList,
catOfList,
comments,
ruleTokens,
tokenPragmas,
tokenNames,
precCat,
precLevels,
precRule,
precCF,
isUsedCat,
internalCat,
isPositionCat,
isNormal,
isAqFun,
hasIdent,
hasLayout,
hasAq,
rename,
renameAq,
renameAqt,
unAq,
unAqs,
aqSyntax,
layoutPragmas,
derivations,
checkRule,
visibleNames,
quoterName,
quoters,
) where
import Language.LBNF.Utils (prParenth,(+++))
import Data.List (nub, intersperse, partition, sort,sort,group)
import Data.Char
import Language.LBNF.Grammar (Reg())
type CF = (Exts,[Rule])
rulesOfCF :: CF -> [Rule]
rulesOfCF = snd
infoOfCF :: CFG f -> Info
infoOfCF = snd . fst
pragmasOfCF :: CFG f -> [Pragma]
pragmasOfCF = fst . fst
isTokenRule :: Rule -> Bool
isTokenRule = either (const False) (const True) . rhsRule
funRule :: Rule -> Fun
funRule = fst
oldRHS = either id (const [])
rhsRule :: Rule -> RHS
rhsRule = snd . snd
type RHS = Either [Either Cat String] (Reg,String)
type Rule = (Fun, (Cat, RHS))
type Rul f = Rule
type CFG f = CF
type Exts = ([Pragma],Info)
type Info = ([Literal],[Symbol],[KeyWord],[Cat])
data Exp = App String [Exp]
| LitInt Integer
| LitDouble Double
| LitChar Char
| LitString String
deriving (Eq)
instance Show Exp where
showsPrec p e =
case listView e of
Right es ->
showString "["
. foldr (.) id (intersperse (showString ", ") $ map shows es)
. showString "]"
Left (App x []) -> showString x
Left (App "(:)" [e1,e2]) ->
showParen (p>0)
$ showsPrec 1 e1
. showString " : "
. shows e2
Left (App x es) ->
showParen (p>1)
$ foldr (.) id
$ intersperse (showString " ")
$ showString x : map (showsPrec 2) es
Left (LitInt n) -> shows n
Left (LitDouble x) -> shows x
Left (LitChar c) -> shows c
Left (LitString s) -> shows s
where
listView (App "[]" []) = Right []
listView (App "(:)" [e1,e2])
| Right es <- listView e2 = Right $ e1:es
listView e = Left e
data Pragma = CommentS String
| CommentM (String,String)
| TokenReg String Bool Reg
| EntryPoints [Cat]
| Layout [String]
| LayoutStop [String]
| LayoutTop
| Derive [String]
| FunDef String [String] Exp
| AntiQuote String String String
deriving (Show, Eq)
ruleTokens :: CF -> [(String,Reg)]
ruleTokens cf = [(token,reg) | (fun,(c,Right (reg,token))) <- rulesOfCF cf]
tokenPragmas :: CF -> [(String,Reg)]
tokenPragmas cf = [(name,exp) | TokenReg name _ exp <- pragmasOfCF cf]
tokenNames :: CF -> [String]
tokenNames cf = fst (unzip (tokenPragmas cf))
layoutPragmas :: CF -> (Bool,[String],[String])
layoutPragmas cf = let ps = pragmasOfCF cf in (
not (null [() | LayoutTop <- ps]),
concat [ss | Layout ss <- ps],
concat [ss | LayoutStop ss <- ps]
)
derivations :: CF -> [String]
derivations cf = case concat [ss|Derive ss <- pragmasOfCF cf] of
[] -> ["Show", "Eq", "Ord"]
x -> x
hasLayout :: CF -> Bool
hasLayout cf = case layoutPragmas cf of
(t,ws,_) -> t || not (null ws)
hasAq :: CF -> Bool
hasAq cf = case [(b,a) | AntiQuote b i a <- pragmasOfCF cf] of
[] -> False
_ -> True
aqSyntax :: CF -> Maybe (String,String,String)
aqSyntax cf = case [(b,i,a) | AntiQuote b i a <- pragmasOfCF cf] of
[] -> Nothing
[t] -> Just t
many -> error "aqSyntax: Multiple antiquote pragmas"
rename s = case s of
"_" -> s
"$" -> s
"#" -> s
"(:)" -> s
"(:[])" -> s
"[]" -> s
('$':s) -> "AQ___" ++ s
('[':l) -> '[' : rename (init l) ++ "]"
_ -> "AQ_" ++ normCat s ++ number s
renameAqt s = case s of
('[':l) -> '[' : renameAqt (init l) ++ "]"
_ -> "AQ___" ++ normCat s ++ number s
renameAq s = case s of
('[':l) -> '[' : renameAq (init l) ++ "]"
_ -> "AQ__" ++ normCat s ++ number s
number = reverse . takeWhile isDigit . reverse
unAq s = case s of
'A':'Q':'_':r -> Just r
_ -> Nothing
unAqs s = case s of
'A':'Q':'_':'_':'_':r -> Just r
'A':'Q':'_':'_':r -> Just r
_ -> Nothing
type Literal = Cat
type Symbol = String
type KeyWord = String
type Cat = String
type Fun = String
internalCat :: Cat
internalCat = "#"
newtype Tree = Tree (Fun,[Tree])
type Data = (Cat, [(Fun,Either [Cat] String)])
firstCat :: CF -> Cat
firstCat = valCat . head . rulesOfCF
firstEntry :: CF -> Cat
firstEntry cf = case allEntryPoints cf of
(x:_) -> x
_ -> firstCat cf
notUniqueFuns :: CF -> [Fun]
notUniqueFuns cf = let xss = group $ sort [ f | (f,_) <- rulesOfCF cf,
not (isNilCons f || isCoercion f)]
in [ head xs | xs <- xss, length xs > 1]
badInheritence :: CF -> [Cat]
badInheritence cf = concatMap checkGroup (ruleGroups cf)
where
checkGroup (cat, rs) = if (length rs <= 1)
then []
else case lookup cat rs of
Nothing -> []
Just x -> [cat]
commentPragmas :: [Pragma] -> [Pragma]
commentPragmas = filter isComment
where isComment (CommentS _) = True
isComment (CommentM _) = True
isComment _ = False
rulesForCat :: CF -> Cat -> [Rule]
rulesForCat cf cat = [normRuleFun r | r <- rulesOfCF cf, isParsable r, valCat r == cat]
rulesForCat' :: CF -> Cat -> [Rule]
rulesForCat' cf cat = [normRuleFun r | r <- rulesOfCF cf, valCat r == cat]
valCat :: Rul f -> Cat
valCat = fst . snd
allCats :: CF -> [Cat]
allCats = nub . map valCat . rulesOfCF
allCatsIdNorm :: CF -> [Cat]
allCatsIdNorm = nub . map identCat . map normCat . allCats
isUsedCat :: CF -> Cat -> Bool
isUsedCat cf cat = elem cat [c | r <- (rulesOfCF cf), Left c <- oldRHS (rhsRule r)]
allEntryPoints :: CF -> [Cat]
allEntryPoints cf = case concat [cats | EntryPoints cats <- pragmasOfCF cf] of
[] -> allCats cf
cs -> cs
ruleGroups :: CF -> [(Cat,[Rule])]
ruleGroups cf = [(c, rulesForCat cf c) | c <- allCats cf]
ruleGroupsInternals :: CF -> [(Cat,[Rule])]
ruleGroupsInternals cf = [(c, rulesForCat' cf c) | c <- allCats cf]
typed_literals :: CF -> [(Fun,Cat)]
typed_literals cf = map (\x -> (x,x)) lits ++ owns
where
(lits,_,_,_) = infoOfCF cf
owns = map (\(x,_) -> (x,x)) (tokenPragmas cf)
rulets = [(fun,c) | (fun,(c,Right reg)) <- rulesOfCF cf]
literals :: CF -> [Cat]
literals cf = lits ++ owns
where
(lits,_,_,_) = infoOfCF cf
owns = map fst $ tokenPragmas cf ++ ruleTokens cf
symbols :: CFG f -> [String]
symbols cf = syms
where (_,syms,_,_) = infoOfCF cf
reservedWords :: CFG f -> [String]
reservedWords cf = sort keywords
where (_,_,keywords,_) = infoOfCF cf
reversibleCats :: CFG f -> [Cat]
reversibleCats cf = cats
where (_,_,_,cats) = infoOfCF cf
comments :: CF -> ([(String,String)],[String])
comments cf = case commentPragmas (pragmasOfCF cf) of
xs -> ([p | CommentM p <- xs],
[s | CommentS s <- xs])
hasIdent :: CF -> Bool
hasIdent cf = isUsedCat cf "Ident"
specialCats :: CF -> [Cat]
specialCats cf = (if hasIdent cf then ("Ident":) else id) (map fst (tokenPragmas cf))
specialCatsP :: [Cat]
specialCatsP = words "Ident Integer String Char Double"
prTree :: Tree -> String
prTree (Tree (fun,[])) = fun
prTree (Tree (fun,trees)) = fun +++ unwords (map pr2 trees) where
pr2 t@(Tree (_,ts)) = (if (null ts) then id else prParenth) (prTree t)
cf2data :: CF -> [Data]
cf2data cf =
[(cat, nub (map mkData [r | r@(f,_) <- rulesOfCF cf,
not (isDefinedRule f),
not (isCoercion f), eqCat cat (valCat r),
not (isAqFun f)]))
| cat <- allNormalCats cf]
where
mkData :: Rule -> (Fun,Either [Cat] (String))
mkData (f,(_,Left its)) = (normFun f,Left [normCat c | Left c <- its, c /= internalCat])
mkData (f,(_,Right (r,tok))) = (normFun f,Right tok)
specialData :: CF -> [Data]
specialData cf = [(c,[(c,Left [arg c])]) | c <- specialCats cf] where
arg c = case c of
_ -> "String"
allNormalCats :: CF -> [Cat]
allNormalCats = filter isNormal . allCats
isCoercion :: Fun -> Bool
isCoercion = (== "_")
isDefinedRule :: Fun -> Bool
isDefinedRule (x:_) = isLower x
isProperLabel :: Fun -> Bool
isProperLabel f = not (isCoercion f || isDefinedRule f)
eqCat :: Cat -> Cat -> Bool
eqCat c c1 = catCat c == catCat c1
normCat :: Cat -> Cat
normCat c = case c of
'[':cs -> "[" ++ norm (init cs) ++ "]"
_ -> unList $ norm c
where
norm = reverse . dropWhile isDigit . reverse
normCatOfList :: Cat -> Cat
normCatOfList = normCat . catOfList
identCat :: Cat -> Cat
identCat c = case c of
'[':cs -> "List" ++ identCat (init cs)
_ -> c
normFun :: Fun -> Fun
normFun = id
normRuleFun :: Rule -> Rule
normRuleFun (f,p) = (normFun f, p)
isNormal :: Cat -> Bool
isNormal c = not (isList c || isDigit (last c) || isAqFun c)
isParsable :: Rul f -> Bool
isParsable (_,(_, Left (Left "#":_))) = False
isParsable (_,(_, Left (Left "$":_))) = False
isParsable _ = True
isList :: Cat -> Bool
isList c = head c == '['
unList :: Cat -> Cat
unList c = c
catOfList :: Cat -> Cat
catOfList c = case c of
'[':_:_ -> init (tail c)
_ -> c
isNilFun, isOneFun, isConsFun, isNilCons, isAqFun :: Fun -> Bool
isNilCons f = isNilFun f || isOneFun f || isConsFun f
isNilFun f = f == "[]"
isOneFun f = f == "(:[])"
isConsFun f = f == "(:)"
isEmptyListCat :: CF -> Cat -> Bool
isEmptyListCat cf c = elem "[]" $ map fst $ rulesForCat' cf c
isNonterm = either (const True) (const False)
isAqFun ('$':_) = True
isAqFun _ = False
revSepListRule :: Rul f -> Rul f
revSepListRule r@(f,(c, Left ts)) = (f, (c, Left $ xs : x : sep)) where
(x,sep,xs) = (head ts, init (tail ts), last ts)
revSepListRule x = x
findAllReversibleCats :: CF -> [Cat]
findAllReversibleCats cf = [c | (c,r) <- ruleGroups cf, isRev c r] where
isRev c rs = case rs of
[r1,r2] | isList c -> if isConsFun (funRule r2)
then tryRev r2 r1
else if isConsFun (funRule r1)
then tryRev r1 r2
else False
_ -> False
tryRev :: Rule -> Rule -> Bool
tryRev (f,(_,Left (ts@(x:_:xs)))) r = isEmptyNilRule r &&
isConsFun f && isNonterm x && isNonterm (last ts)
tryRev _ _ = False
isEmptyNilRule (f,(_,Left ts)) = isNilFun f && null ts
isEmptyNilRule _ = False
precCat :: Cat -> Int
precCat = snd . analyseCat
precRule :: Rule -> Int
precRule = precCat . valCat
precLevels :: CF -> [Int]
precLevels cf = sort $ nub $ [ precCat c | c <- allCats cf]
precCF :: CF -> Bool
precCF cf = length (precLevels cf) > 1
catCat :: Cat -> Cat
catCat = fst . analyseCat
analyseCat :: Cat -> (Cat,Int)
analyseCat c = if (isList c) then list c else noList c
where
list cat = let (rc,n) = noList (init (tail cat)) in ("[" ++ rc ++ "]",n)
noList cat = case span isDigit (reverse cat) of
([],c') -> (reverse c', 0)
(d,c') -> (reverse c', read (reverse d))
checkRule :: CF -> Rule -> Either Rule String
checkRule cf r@(f,(cat,rhs))
| badCoercion = Right $ "Bad coercion in rule" +++ s
| badNil = Right $ "Bad empty list rule" +++ s
| badOne = Right $ "Bad one-element list rule" +++ s
| badCons = Right $ "Bad list construction rule" +++ s
| badList = Right $ "Bad list formation rule" +++ s
| badSpecial = Right $ "Bad special category rule" +++ s
| badTypeName = Right $ "Bad type name" +++ unwords badtypes +++ "in" +++ s
| badFunName = Right $ "Bad constructor name" +++ f +++ "in" +++ s
| badMissing = Right $ "No production for" +++ unwords missing ++
", appearing in rule" +++ s
| otherwise = Left r
where
s = f ++ "." +++ cat +++ "::=" +++ unwords (map (either id show) $ transRHS rhs)
c = normCat cat
cs = [normCat c | Left c <- transRHS rhs]
badCoercion = isCoercion f && not ([c] == cs)
badNil = isNilFun f && not (isList c && null cs)
badOne = isOneFun f && not (isList c && cs == [catOfList c])
badCons = isConsFun f && not (isList c && cs == [catOfList c, c])
badList = isList c &&
not (isCoercion f || isNilFun f || isOneFun f || isConsFun f || isAqFun f)
badSpecial = elem c specialCatsP && not (isCoercion f)
badMissing = not (null missing)
missing = filter nodef [c | Left c <- transRHS rhs]
nodef t = notElem t defineds
defineds =
"#" : map fst (tokenPragmas cf) ++ specialCatsP ++ map valCat (rulesOfCF cf)
badTypeName = not (null badtypes)
badtypes = filter isBadType $ cat : [c | Left c <- transRHS rhs]
isBadType c = not (isUpper (head c) || isList c || c == "#")
badFunName = not (all (\c -> isAlphaNum c || c == '_') f
|| isCoercion f || isNilFun f || isOneFun f || isConsFun f || isAqFun f)
transRHS :: RHS -> [Either Cat String]
transRHS = either id (const [])
isPositionCat :: CFG f -> Cat -> Bool
isPositionCat cf cat = or [b | TokenReg name b _ <- pragmasOfCF cf, name == cat]
visibleNames :: CF -> [String]
visibleNames cf = "myLexer":"tokens":map ('p':) eps ++ map ('q':) eps ++ map initLower eps where
eps = quoters cf
quoterName :: String -> String
quoterName = initLower
quoters :: CF -> [String]
quoters = map identCat . allEntryPoints
initLower :: String -> String
initLower [] = error "initLower : Empty list"
initLower (c:cs) = toLower c : cs