forked from GitHub/gf-core
clean up the GF.Grammar API
This commit is contained in:
krasimir
@@ -1,38 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Abstract
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:18 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.Abstract (
|
||||
|
||||
module GF.Grammar.Grammar,
|
||||
module GF.Grammar.Values,
|
||||
module GF.Grammar.Macros,
|
||||
module GF.Infra.Ident,
|
||||
module GF.Grammar.MMacros,
|
||||
module GF.Grammar.Printer,
|
||||
|
||||
Grammar
|
||||
|
||||
) where
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Values
|
||||
import GF.Grammar.Macros
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.MMacros
|
||||
import GF.Grammar.Printer
|
||||
|
||||
type Grammar = SourceGrammar ---
|
||||
|
||||
|
||||
|
||||
128
src/GF/Grammar/CF.hs
Normal file
128
src/GF/Grammar/CF.hs
Normal file
@@ -0,0 +1,128 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : CF
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/15 17:56:13 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.13 $
|
||||
--
|
||||
-- parsing CF grammars and converting them to GF
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.CF (getCF) where
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Modules
|
||||
import GF.Infra.Option
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
getCF :: String -> String -> Err SourceGrammar
|
||||
getCF name = fmap (cf2gf name) . pCF
|
||||
|
||||
---------------------
|
||||
-- the parser -------
|
||||
---------------------
|
||||
|
||||
pCF :: String -> Err CF
|
||||
pCF s = do
|
||||
rules <- mapM getCFRule $ filter isRule $ lines s
|
||||
return $ concat rules
|
||||
where
|
||||
isRule line = case dropWhile isSpace line of
|
||||
'-':'-':_ -> False
|
||||
_ -> not $ all isSpace line
|
||||
|
||||
-- rules have an amazingly easy parser, if we use the format
|
||||
-- fun. C -> item1 item2 ... where unquoted items are treated as cats
|
||||
-- Actually would be nice to add profiles to this.
|
||||
|
||||
getCFRule :: String -> Err [CFRule]
|
||||
getCFRule s = getcf (wrds s) where
|
||||
getcf ws = case ws of
|
||||
fun : cat : a : its | isArrow a ->
|
||||
Ok [(init fun, (cat, map mkIt its))]
|
||||
cat : a : its | isArrow a ->
|
||||
Ok [(mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
|
||||
_ -> Bad (" invalid rule:" +++ s)
|
||||
isArrow a = elem a ["->", "::="]
|
||||
mkIt w = case w of
|
||||
('"':w@(_:_)) -> Right (init w)
|
||||
_ -> Left w
|
||||
chunk its = case its of
|
||||
[] -> [[]]
|
||||
_ -> chunks "|" its
|
||||
mkFun cat its = case its of
|
||||
[] -> cat ++ "_"
|
||||
_ -> concat $ intersperse "_" (cat : map clean its) -- CLE style
|
||||
clean = filter isAlphaNum -- to form valid identifiers
|
||||
wrds = takeWhile (/= ";") . words -- to permit semicolon in the end
|
||||
|
||||
type CF = [CFRule]
|
||||
|
||||
type CFRule = (CFFun, (CFCat, [CFItem]))
|
||||
|
||||
type CFItem = Either CFCat String
|
||||
|
||||
type CFCat = String
|
||||
type CFFun = String
|
||||
|
||||
--------------------------
|
||||
-- the compiler ----------
|
||||
--------------------------
|
||||
|
||||
cf2gf :: String -> CF -> SourceGrammar
|
||||
cf2gf name cf = MGrammar [
|
||||
(aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat}))
|
||||
(emptyModInfo{mtype = MTAbstract, jments = abs})),
|
||||
(cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc})
|
||||
]
|
||||
where
|
||||
(abs,cnc,cat) = cf2grammar cf
|
||||
aname = identS $ name ++ "Abs"
|
||||
cname = identS name
|
||||
|
||||
|
||||
cf2grammar :: CF -> (BinTree Ident Info, BinTree Ident Info, String)
|
||||
cf2grammar rules = (buildTree abs, buildTree conc, cat) where
|
||||
abs = cats ++ funs
|
||||
conc = lincats ++ lins
|
||||
cat = case rules of
|
||||
(_,(c,_)):_ -> c -- the value category of the first rule
|
||||
_ -> error "empty CF"
|
||||
cats = [(cat, AbsCat (Just []) (Just [])) |
|
||||
cat <- nub (concat (map cf2cat rules))] ----notPredef cat
|
||||
lincats = [(cat, CncCat (Just defLinType) Nothing Nothing) | (cat,AbsCat _ _) <- cats]
|
||||
(funs,lins) = unzip (map cf2rule rules)
|
||||
|
||||
cf2cat :: CFRule -> [Ident]
|
||||
cf2cat (_,(cat, items)) = map identS $ cat : [c | Left c <- items]
|
||||
|
||||
cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
|
||||
cf2rule (fun, (cat, items)) = (def,ldef) where
|
||||
f = identS fun
|
||||
def = (f, AbsFun (Just (mkProd (args', Cn (identS cat), []))) Nothing Nothing)
|
||||
args0 = zip (map (identS . ("x" ++) . show) [0..]) items
|
||||
args = [(v, Cn (identS c)) | (v, Left c) <- args0]
|
||||
args' = [(identS "_", Cn (identS c)) | (_, Left c) <- args0]
|
||||
ldef = (f, CncFun
|
||||
Nothing
|
||||
(Just (mkAbs (map fst args)
|
||||
(mkRecord (const theLinLabel) [foldconcat (map mkIt args0)])))
|
||||
Nothing)
|
||||
mkIt (v, Left _) = P (Vr v) theLinLabel
|
||||
mkIt (_, Right a) = K a
|
||||
foldconcat [] = K ""
|
||||
foldconcat tt = foldr1 C tt
|
||||
|
||||
identS = identC . BS.pack
|
||||
|
||||
File diff suppressed because one or more lines are too long
@@ -1,255 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : PrGrammar
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/04 11:45:38 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.16 $
|
||||
--
|
||||
-- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003
|
||||
--
|
||||
-- printing and prettyprinting class
|
||||
--
|
||||
-- 8\/1\/2004:
|
||||
-- Usually followed principle: 'prt_' for displaying in the editor, 'prt'
|
||||
-- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree',
|
||||
-- only the former is ever needed.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.PrGrammar (Print(..),
|
||||
prtBad,
|
||||
prGrammar,
|
||||
prConstrs,
|
||||
prTermTabular
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
--import GF.Data.Zipper
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Modules
|
||||
import qualified GF.Source.PrintGF as P
|
||||
import GF.Grammar.Values
|
||||
import GF.Source.GrammarToSource
|
||||
--- import GFC (CanonGrammar) --- cycle of modules
|
||||
|
||||
import GF.Infra.Option
|
||||
import GF.Infra.Ident
|
||||
|
||||
import GF.Infra.CompactPrint
|
||||
|
||||
import Data.List (intersperse)
|
||||
|
||||
class Print a where
|
||||
prt :: a -> String
|
||||
-- | printing with parentheses, if needed
|
||||
prt2 :: a -> String
|
||||
-- | pretty printing
|
||||
prpr :: a -> [String]
|
||||
-- | printing without ident qualifications
|
||||
prt_ :: a -> String
|
||||
prt2 = prt
|
||||
prt_ = prt
|
||||
prpr = return . prt
|
||||
|
||||
-- 8/1/2004
|
||||
--- Usually followed principle: prt_ for displaying in the editor, prt
|
||||
--- in writing grammars to a file. For some constructs, e.g. prMarkedTree,
|
||||
--- only the former is ever needed.
|
||||
|
||||
-- | to show terms etc in error messages
|
||||
prtBad :: Print a => String -> a -> Err b
|
||||
prtBad s a = Bad (s +++ prt a)
|
||||
|
||||
pprintTree :: P.Print a => a -> String
|
||||
pprintTree = compactPrint . P.printTree
|
||||
|
||||
prGrammar :: SourceGrammar -> String
|
||||
prGrammar = pprintTree . trGrammar
|
||||
|
||||
prModule :: SourceModule -> String
|
||||
prModule = pprintTree . trModule
|
||||
|
||||
instance Print Term where
|
||||
prt = pprintTree . trt
|
||||
prt_ = prExp
|
||||
|
||||
instance Print Ident where
|
||||
prt = pprintTree . tri
|
||||
|
||||
instance Print Patt where
|
||||
prt = pprintTree . trp
|
||||
prt_ = prt . unqual where
|
||||
unqual p = case p of
|
||||
PP _ c [] -> PV c --- to remove curlies
|
||||
PP _ c ps -> PC c (map unqual ps)
|
||||
PC c ps -> PC c (map unqual ps)
|
||||
_ -> p ---- records
|
||||
|
||||
instance Print Label where
|
||||
prt = pprintTree . trLabel
|
||||
|
||||
instance Print MetaSymb where
|
||||
prt (MetaSymb i) = "?" ++ show i
|
||||
|
||||
prParam :: Param -> String
|
||||
prParam (c,co) = prt c +++ prContext co
|
||||
|
||||
prContext :: Context -> String
|
||||
prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co]
|
||||
|
||||
-- some GFC notions
|
||||
{-
|
||||
instance Print a => Print (Tr a) where
|
||||
prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees)
|
||||
prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t)
|
||||
|
||||
-- | we cannot define the method prt_ in this way
|
||||
prt_Tree :: Tree -> String
|
||||
prt_Tree = prt_ . tree2exp
|
||||
|
||||
instance Print TrNode where
|
||||
prt (N (bi,at,vt,(cs,ms),_)) =
|
||||
prBinds bi ++
|
||||
prt at +++ ":" +++ prt vt
|
||||
+++ prConstraints cs +++ prMetaSubst ms
|
||||
prt_ (N (bi,at,vt,(cs,ms),_)) =
|
||||
prBinds bi ++
|
||||
prt_ at +++ ":" +++ prt_ vt
|
||||
+++ prConstraints cs +++ prMetaSubst ms
|
||||
|
||||
prMarkedTree :: Tr (TrNode,Bool) -> [String]
|
||||
prMarkedTree = prf 1 where
|
||||
prf ind t@(Tr (node, trees)) =
|
||||
prNode ind node : concatMap (prf (ind + 2)) trees
|
||||
prNode ind node = case node of
|
||||
(n, False) -> indent ind (prt_ n)
|
||||
(n, _) -> '*' : indent (ind - 1) (prt_ n)
|
||||
|
||||
prTree :: Tree -> [String]
|
||||
prTree = prMarkedTree . mapTr (\n -> (n,False))
|
||||
|
||||
-- | a pretty-printer for parsable output
|
||||
tree2string :: Tree -> String
|
||||
tree2string = unlines . prprTree
|
||||
|
||||
prprTree :: Tree -> [String]
|
||||
prprTree = prf False where
|
||||
prf par t@(Tr (node, trees)) =
|
||||
parIf par (prn node : concat [prf (ifPar t) t | t <- trees])
|
||||
prn (N (bi,at,_,_,_)) = prb bi ++ prt_ at
|
||||
prb [] = ""
|
||||
prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> "
|
||||
parIf par (s:ss) = map (indent 2) $
|
||||
if par
|
||||
then ('(':s) : ss ++ [")"]
|
||||
else s:ss
|
||||
ifPar (Tr (N ([],_,_,_,_), [])) = False
|
||||
ifPar _ = True
|
||||
-}
|
||||
|
||||
-- auxiliaries
|
||||
|
||||
prMetaSubst :: MetaSubst -> String
|
||||
prMetaSubst = concat . prMSubst
|
||||
|
||||
prConstrs :: Constraints -> [String]
|
||||
prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w))
|
||||
|
||||
prMSubst :: MetaSubst -> [String]
|
||||
prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e))
|
||||
|
||||
prBinds bi = if null bi
|
||||
then []
|
||||
else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> "
|
||||
where
|
||||
prValDecl (x,t) = prParenth (prt_ x +++ ":" +++ prt_ t)
|
||||
{-
|
||||
instance Print Atom where
|
||||
prt (AtC f) = prQIdent f
|
||||
prt (AtM i) = prt i
|
||||
prt (AtV i) = prt i
|
||||
prt (AtL s) = prQuotedString s
|
||||
prt (AtI i) = show i
|
||||
prt (AtF i) = show i
|
||||
prt_ (AtC (_,f)) = prt f
|
||||
prt_ a = prt a
|
||||
-}
|
||||
prEnv :: Env -> String
|
||||
---- prEnv [] = prCurly "" ---- for debugging
|
||||
prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e
|
||||
|
||||
|
||||
instance Print Val where
|
||||
prt (VGen i x) = prt x ++ "{-" ++ show i ++ "-}" ---- latter part for debugging
|
||||
prt (VApp u v) = prt u +++ prv1 v
|
||||
prt (VCn mc) = prQIdent_ mc
|
||||
prt (VClos env e) = case e of
|
||||
Meta _ -> prt_ e ++ prEnv env
|
||||
_ -> prt_ e ---- ++ prEnv env ---- for debugging
|
||||
prt (VRecType xs) = prCurly (concat (intersperse "," [prt l ++ "=" ++ prt v | (l,v) <- xs]))
|
||||
prt VType = "Type"
|
||||
|
||||
prv1 v = case v of
|
||||
VApp _ _ -> prParenth $ prt v
|
||||
VClos _ _ -> prParenth $ prt v
|
||||
_ -> prt v
|
||||
|
||||
|
||||
prQIdent :: QIdent -> String
|
||||
prQIdent (m,f) = prt m ++ "." ++ prt f
|
||||
|
||||
prQIdent_ :: QIdent -> String
|
||||
prQIdent_ (_,f) = prt f
|
||||
|
||||
-- | print terms without qualifications
|
||||
prExp :: Term -> String
|
||||
prExp e = case e of
|
||||
App f a -> pr1 f +++ pr2 a
|
||||
Abs x b -> "\\" ++ prt x +++ "->" +++ prExp b
|
||||
Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
|
||||
Q _ c -> prt c
|
||||
QC _ c -> prt c
|
||||
_ -> prt e
|
||||
where
|
||||
pr1 e = case e of
|
||||
Abs _ _ -> prParenth $ prExp e
|
||||
Prod _ _ _ -> prParenth $ prExp e
|
||||
_ -> prExp e
|
||||
pr2 e = case e of
|
||||
App _ _ -> prParenth $ prExp e
|
||||
_ -> pr1 e
|
||||
|
||||
-- | option @-strip@ strips qualifications
|
||||
prTermOpt :: Options -> Term -> String
|
||||
prTermOpt opts = if PrinterStrip `elem` flag optPrinter opts then prt else prExp
|
||||
|
||||
-- | to get rid of brackets in the editor
|
||||
prRefinement :: Term -> String
|
||||
prRefinement t = case t of
|
||||
Q m c -> prQIdent (m,c)
|
||||
QC m c -> prQIdent (m,c)
|
||||
_ -> prt t
|
||||
|
||||
prOperSignature :: (QIdent,Type) -> String
|
||||
prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t
|
||||
|
||||
--- printing cc command output AR 26/5/2008
|
||||
|
||||
prTermTabular :: Term -> [(String,String)]
|
||||
prTermTabular = pr where
|
||||
pr t = case t of
|
||||
R rs ->
|
||||
[(prt_ lab +++ "." +++ path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
|
||||
T _ cs ->
|
||||
[(prt_ lab +++"=>" +++ path, str) | (lab, val) <- cs, (path,str) <- pr val]
|
||||
V _ cs ->
|
||||
[("#" ++ show i +++"=>" +++ path, str) | (i,val) <- zip [0..] cs, (path,str) <- pr val]
|
||||
_ -> [([],ps t)]
|
||||
ps t = case t of
|
||||
K s -> s
|
||||
C s u -> ps s +++ ps u
|
||||
FV ts -> unwords (intersperse "/" (map ps ts))
|
||||
_ -> prt_ t
|
||||
@@ -17,7 +17,7 @@
|
||||
|
||||
module GF.Grammar.Unify (unifyVal) where
|
||||
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Grammar
|
||||
import GF.Data.Operations
|
||||
|
||||
import Text.PrettyPrint
|
||||
|
||||
Reference in New Issue
Block a user