forked from GitHub/gf-core
printing new source format
This commit is contained in:
aarne
221
src/GF/Devel/Grammar/GFtoSource.hs
Normal file
221
src/GF/Devel/Grammar/GFtoSource.hs
Normal file
@@ -0,0 +1,221 @@
|
||||
module GF.Devel.Grammar.GFtoSource (
|
||||
trGrammar,
|
||||
trModule,
|
||||
trAnyDef,
|
||||
trLabel,
|
||||
trt,
|
||||
tri,
|
||||
trp
|
||||
) where
|
||||
|
||||
|
||||
import GF.Devel.Grammar.Modules
|
||||
import GF.Devel.Grammar.Judgements
|
||||
import GF.Devel.Grammar.Terms
|
||||
import GF.Devel.Grammar.Macros (contextOfType)
|
||||
import qualified GF.Devel.Grammar.AbsGF as P
|
||||
import GF.Infra.Ident
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-- From internal source syntax to BNFC-generated (used for printing).
|
||||
-- | AR 13\/5\/2003
|
||||
--
|
||||
-- translate internal to parsable and printable source
|
||||
|
||||
trGrammar :: GF -> P.Grammar
|
||||
trGrammar = P.Gr . map trModule . listModules -- no includes
|
||||
|
||||
trModule :: (Ident,Module) -> P.ModDef
|
||||
trModule (i,mo) = P.MModule compl typ body where
|
||||
compl = case isCompleteModule mo of
|
||||
False -> P.CMIncompl
|
||||
_ -> P.CMCompl
|
||||
i' = tri i
|
||||
typ = case mtype mo of
|
||||
MTGrammar -> P.MGrammar i'
|
||||
MTAbstract -> P.MAbstract i'
|
||||
MTConcrete a -> P.MConcrete i' (tri a)
|
||||
body = P.MBody
|
||||
(trExtends (mextends mo))
|
||||
(mkOpens (map trOpen (mopens mo)))
|
||||
(concatMap trAnyDef [(c,j) | (c,Left j) <- listJudgements mo] ++
|
||||
map trFlag (Map.assocs (mflags mo)))
|
||||
|
||||
trExtends :: [(Ident,MInclude)] -> P.Extend
|
||||
trExtends [] = P.NoExt
|
||||
trExtends es = (P.Ext $ map tre es) where
|
||||
tre (i,c) = case c of
|
||||
MIAll -> P.IAll (tri i)
|
||||
MIOnly is -> P.ISome (tri i) (map tri is)
|
||||
MIExcept is -> P.IMinus (tri i) (map tri is)
|
||||
|
||||
trOpen :: (Ident,Ident) -> P.Open
|
||||
trOpen (i,j) = P.OQual (tri i) (tri j)
|
||||
|
||||
mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
|
||||
|
||||
trAnyDef :: (Ident,Judgement) -> [P.TopDef]
|
||||
trAnyDef (i,ju) = let
|
||||
i' = mkName i
|
||||
i0 = tri i
|
||||
in case jform ju of
|
||||
JCat -> [P.DefCat [P.SimpleCatDef i0 []]] ---- (map trDecl co)]]
|
||||
JFun -> [P.DefFun [P.FDecl [i'] (trt (jtype ju))]]
|
||||
---- ++ case pt of
|
||||
---- Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
|
||||
---- _ -> []
|
||||
---- JFun ty EData -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
|
||||
JParam -> [P.DefPar [
|
||||
P.ParDefDir i0 [
|
||||
P.ParConstr (tri c) (map trDecl co) |
|
||||
(c,co) <- [(k,contextOfType t) | (k,t) <- contextOfType (jtype ju)]
|
||||
]
|
||||
]]
|
||||
JOper -> case jdef ju of
|
||||
Overload tysts ->
|
||||
[P.DefOper [P.DDef [i'] (
|
||||
P.EApp (P.EPIdent $ ppIdent "overload")
|
||||
(P.ERecord [P.LDFull [i0] (trt ty) (trt fu) | (ty,fu) <- tysts]))]]
|
||||
tr -> [P.DefOper [trDef i (jtype ju) tr]]
|
||||
JLincat -> [P.DefLincat [P.DDef [i'] (trt (jtype ju))]]
|
||||
---- CncCat pty ptr ppr ->
|
||||
---- [P.DefLindef [trDef i' pty ptr]]
|
||||
---- ++ [P.DefPrintCat [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
|
||||
JLin ->
|
||||
[P.DefLin [trDef i (Meta 0) (jdef ju)]]
|
||||
---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
|
||||
{-
|
||||
---- encoding of AnyInd without changing syntax. AR 20/9/2007
|
||||
AnyInd s b ->
|
||||
[P.DefOper [P.DDef [mkName i]
|
||||
(P.EApp (P.EInt (if s then 1 else 0)) (P.EIdent (tri b)))]]
|
||||
-}
|
||||
|
||||
|
||||
trDef :: Ident -> Type -> Term -> P.Def
|
||||
trDef i pty ptr = case (pty,ptr) of
|
||||
(Meta _, Meta _) -> P.DDef [mkName i] (P.EMeta) ---
|
||||
(_, Meta _) -> P.DDecl [mkName i] (trPerh pty)
|
||||
(Meta _, _) -> P.DDef [mkName i] (trPerh ptr)
|
||||
(_, _) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr)
|
||||
|
||||
trPerh p = case p of
|
||||
Meta _ -> P.EMeta
|
||||
_ -> trt p
|
||||
|
||||
trFlag :: (Ident,String) -> P.TopDef
|
||||
trFlag (f,x) = P.DefFlag [P.DDef [mkName f] (P.EString x)]
|
||||
|
||||
trt :: Term -> P.Exp
|
||||
trt trm = case trm of
|
||||
Vr s -> P.EPIdent $ tri s
|
||||
---- Cn s -> P.ECons $ tri s
|
||||
Con s -> P.EConstr $ tri s
|
||||
Sort s -> P.ESort $ case s of
|
||||
"Type" -> P.Sort_Type
|
||||
"PType" -> P.Sort_PType
|
||||
"Tok" -> P.Sort_Tok
|
||||
"Str" -> P.Sort_Str
|
||||
"Strs" -> P.Sort_Strs
|
||||
_ -> error $ "not yet sort " +++ show trm ----
|
||||
|
||||
App c a -> P.EApp (trt c) (trt a)
|
||||
Abs x b -> P.EAbstr [trb x] (trt b)
|
||||
Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
|
||||
Meta m -> P.EMeta
|
||||
Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
|
||||
Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
|
||||
|
||||
Example t s -> P.EExample (trt t) s
|
||||
R [] -> P.ETuple [] --- to get correct parsing when read back
|
||||
R r -> P.ERecord $ map trAssign r
|
||||
RecType r -> P.ERecord $ map trLabelling r
|
||||
ExtR x y -> P.EExtend (trt x) (trt y)
|
||||
P t l -> P.EProj (trt t) (trLabel l)
|
||||
PI t l _ -> P.EProj (trt t) (trLabel l)
|
||||
Q t l -> P.EQCons (tri t) (tri l)
|
||||
QC t l -> P.EQConstr (tri t) (tri l)
|
||||
T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc)
|
||||
T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
|
||||
T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
|
||||
T _ cc -> P.ETable (map trCase cc)
|
||||
V ty cc -> P.EVTable (trt ty) (map trt cc)
|
||||
|
||||
Table x v -> P.ETType (trt x) (trt v)
|
||||
S f x -> P.ESelect (trt f) (trt x)
|
||||
Let (x,(ma,b)) t ->
|
||||
P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b') ma] (trt t)
|
||||
where
|
||||
b' = trt b
|
||||
x' = [tri x]
|
||||
Empty -> P.EEmpty
|
||||
K [] -> P.EEmpty
|
||||
K a -> P.EString a
|
||||
C a b -> P.EConcat (trt a) (trt b)
|
||||
|
||||
EInt i -> P.EInt i
|
||||
EFloat i -> P.EFloat i
|
||||
|
||||
Glue a b -> P.EGlue (trt a) (trt b)
|
||||
Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
|
||||
FV ts -> P.EVariants $ map trt ts
|
||||
EData -> P.EData
|
||||
_ -> error $ "not yet" +++ show trm ----
|
||||
|
||||
trp :: Patt -> P.Patt
|
||||
trp p = case p of
|
||||
PW -> P.PW
|
||||
PV s | isWildIdent s -> P.PW
|
||||
PV s -> P.PV $ tri s
|
||||
PC c [] -> P.PCon $ tri c
|
||||
PC c a -> P.PC (tri c) (map trp a)
|
||||
PP p c [] -> P.PQ (tri p) (tri c)
|
||||
PP p c a -> P.PQC (tri p) (tri c) (map trp a)
|
||||
PR r -> P.PR [P.PA [trLabelIdent l] (trp p) | (l,p) <- r]
|
||||
PString s -> P.PStr s
|
||||
PInt i -> P.PInt i
|
||||
PFloat i -> P.PFloat i
|
||||
PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t)
|
||||
|
||||
PAs x p -> P.PAs (tri x) (trp p)
|
||||
|
||||
PAlt p q -> P.PDisj (trp p) (trp q)
|
||||
PSeq p q -> P.PSeq (trp p) (trp q)
|
||||
PRep p -> P.PRep (trp p)
|
||||
PNeg p -> P.PNeg (trp p)
|
||||
|
||||
|
||||
trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
|
||||
where
|
||||
t' = trt t
|
||||
x = [trLabelIdent lab]
|
||||
|
||||
trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty)
|
||||
|
||||
trCase (patt, trm) = P.Case (trp patt) (trt trm)
|
||||
trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
|
||||
|
||||
trDecl (x,ty) = P.DDDec [trb x] (trt ty)
|
||||
|
||||
tri :: Ident -> P.PIdent
|
||||
tri i = ppIdent (prIdent i)
|
||||
|
||||
ppIdent i = P.PIdent ((0,0),i)
|
||||
|
||||
trb i = if isWildIdent i then P.BWild else P.BPIdent (tri i)
|
||||
|
||||
trLabel :: Label -> P.Label
|
||||
trLabel i = case i of
|
||||
LIdent s -> P.LPIdent $ ppIdent s
|
||||
LVar i -> P.LVar $ toInteger i
|
||||
|
||||
trLabelIdent i = ppIdent $ case i of
|
||||
LIdent s -> s
|
||||
LVar i -> "v" ++ show i --- should not happen
|
||||
|
||||
mkName :: Ident -> P.Name
|
||||
mkName = P.PIdentName . tri
|
||||
|
||||
@@ -20,6 +20,14 @@ data GF = GF {
|
||||
emptyGF :: GF
|
||||
emptyGF = GF Nothing [] empty empty
|
||||
|
||||
type SourceModule = (Ident,Module)
|
||||
|
||||
listModules :: GF -> [SourceModule]
|
||||
listModules = assocs.gfmodules
|
||||
|
||||
addModule :: Ident -> Module -> GF -> GF
|
||||
addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)}
|
||||
|
||||
data Module = Module {
|
||||
mtype :: ModuleType,
|
||||
minterfaces :: [(Ident,Ident)], -- non-empty for functors
|
||||
@@ -33,6 +41,9 @@ data Module = Module {
|
||||
emptyModule :: Ident -> Module
|
||||
emptyModule m = Module MTGrammar [] [] [] [] empty empty
|
||||
|
||||
isCompleteModule :: Module -> Bool
|
||||
isCompleteModule = Prelude.null . minterfaces
|
||||
|
||||
listJudgements :: Module -> [(Ident,Either Judgement Indirection)]
|
||||
listJudgements = assocs . mjments
|
||||
|
||||
|
||||
235
src/GF/Devel/Grammar/PrGF.hs
Normal file
235
src/GF/Devel/Grammar/PrGF.hs
Normal file
@@ -0,0 +1,235 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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 - 4/12/2007
|
||||
--
|
||||
-- printing and prettyprinting class for source grammar
|
||||
--
|
||||
-- 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.Devel.Grammar.PrGF where
|
||||
|
||||
import qualified GF.Devel.Grammar.PrintGF as P
|
||||
import GF.Devel.Grammar.GFtoSource
|
||||
import GF.Devel.Grammar.Modules
|
||||
import GF.Devel.Grammar.Terms
|
||||
----import GF.Grammar.Values
|
||||
|
||||
----import GF.Infra.Option
|
||||
import GF.Infra.Ident
|
||||
----import GF.Data.Str
|
||||
|
||||
import GF.Data.Operations
|
||||
----import GF.Data.Zipper
|
||||
|
||||
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)
|
||||
|
||||
prGF :: GF -> String
|
||||
prGF = P.printTree . trGrammar
|
||||
|
||||
prModule :: SourceModule -> String
|
||||
prModule = P.printTree . trModule
|
||||
|
||||
instance Print Term where
|
||||
prt = P.printTree . trt
|
||||
---- prt_ = prExp
|
||||
|
||||
instance Print Ident where
|
||||
prt = P.printTree . tri
|
||||
|
||||
{- ----
|
||||
instance Print Patt where
|
||||
prt = P.printTree . trp
|
||||
|
||||
instance Print Label where
|
||||
prt = P.printTree . 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]
|
||||
|
||||
|
||||
-- printing values and trees in editing
|
||||
|
||||
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
|
||||
|
||||
prConstraints :: Constraints -> String
|
||||
prConstraints = concat . prConstrs
|
||||
|
||||
prMetaSubst :: MetaSubst -> String
|
||||
prMetaSubst = concat . prMSubst
|
||||
|
||||
prEnv :: Env -> String
|
||||
---- prEnv [] = prCurly "" ---- for debugging
|
||||
prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e
|
||||
|
||||
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 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 VType = "Type"
|
||||
|
||||
prv1 v = case v of
|
||||
VApp _ _ -> prParenth $ prt v
|
||||
VClos _ _ -> prParenth $ prt v
|
||||
_ -> prt v
|
||||
|
||||
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
|
||||
|
||||
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 oElem nostripQualif 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
|
||||
|
||||
-- to look up a constant etc in a search tree
|
||||
|
||||
lookupIdent :: Ident -> BinTree Ident b -> Err b
|
||||
lookupIdent c t = case lookupTree prt c t of
|
||||
Ok v -> return v
|
||||
_ -> prtBad "unknown identifier" c
|
||||
|
||||
lookupIdentInfo :: Module Ident f a -> Ident -> Err a
|
||||
lookupIdentInfo mo i = lookupIdent i (jments mo)
|
||||
-}
|
||||
Reference in New Issue
Block a user