forked from GitHub/gf-core
Founding the newly structured GF2.0 cvs archive.
This commit is contained in:
aarne
319
src/GF/Canon/PrintGFC.hs
Normal file
319
src/GF/Canon/PrintGFC.hs
Normal file
@@ -0,0 +1,319 @@
|
||||
module PrintGFC where
|
||||
|
||||
-- pretty-printer generated by the BNF converter, except handhacked spacing --H
|
||||
|
||||
import Ident --H
|
||||
import AbsGFC
|
||||
import Char
|
||||
|
||||
-- the top-level printing method
|
||||
printTree :: Print a => a -> String
|
||||
printTree = render . prt 0
|
||||
|
||||
-- you may want to change render and parenth
|
||||
|
||||
render :: [String] -> String
|
||||
render = rend 0 where
|
||||
rend i ss = case ss of
|
||||
"NEW" :ts -> realnew $ rend i ts --H
|
||||
"<" :ts -> cons "<" $ rend i ts --H
|
||||
"$" :ts -> cons "$" $ rend i ts --H
|
||||
"?" :ts -> cons "?" $ rend i ts --H
|
||||
"[" :ts -> cons "[" $ rend i ts
|
||||
"(" :ts -> cons "(" $ rend i ts
|
||||
"{" :ts -> cons "{" $ new (i+1) $ rend (i+1) ts
|
||||
"}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts
|
||||
"}" :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts
|
||||
";" :ts -> cons ";" $ new i $ rend i ts
|
||||
t : "," :ts -> cons t $ space "," $ rend i ts
|
||||
t : ")" :ts -> cons t $ cons ")" $ rend i ts
|
||||
t : "]" :ts -> cons t $ cons "]" $ rend i ts
|
||||
t : ">" :ts -> cons t $ cons ">" $ rend i ts --H
|
||||
t : "." :ts -> cons t $ cons "." $ rend i ts --H
|
||||
t :ts -> realspace t $ rend i ts --H
|
||||
_ -> ""
|
||||
cons s t = s ++ t
|
||||
space t s = t ++ " " ++ s --H
|
||||
realspace t s = if null s then t else t ++ " " ++ s --H
|
||||
new i s = s --H '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s
|
||||
realnew s = '\n':s --H
|
||||
|
||||
parenth :: [String] -> [String]
|
||||
parenth ss = ["("] ++ ss ++ [")"]
|
||||
|
||||
-- the printer class does the job
|
||||
class Print a where
|
||||
prt :: Int -> a -> [String]
|
||||
prtList :: [a] -> [String]
|
||||
prtList = concat . map (prt 0)
|
||||
|
||||
instance Print a => Print [a] where
|
||||
prt _ = prtList
|
||||
|
||||
instance Print Integer where
|
||||
prt _ = (:[]) . show
|
||||
|
||||
instance Print Double where
|
||||
prt _ = (:[]) . show
|
||||
|
||||
instance Print Char where
|
||||
prt _ s = ["'" ++ mkEsc s ++ "'"]
|
||||
prtList s = ["\"" ++ concatMap mkEsc s ++ "\""]
|
||||
|
||||
mkEsc s = case s of
|
||||
_ | elem s "\\\"'" -> '\\':[s]
|
||||
'\n' -> "\\n"
|
||||
'\t' -> "\\t"
|
||||
_ -> [s]
|
||||
|
||||
prPrec :: Int -> Int -> [String] -> [String]
|
||||
prPrec i j = if j<i then parenth else id
|
||||
|
||||
|
||||
instance Print Ident where
|
||||
prt _ i = [prIdent i]
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
[x] -> (concat [prt 0 x])
|
||||
x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
|
||||
|
||||
|
||||
|
||||
instance Print Canon where
|
||||
prt i e = case e of
|
||||
Gr modules -> prPrec i 0 (concat [prt 0 modules])
|
||||
|
||||
|
||||
instance Print Module where
|
||||
prt i e = case e of
|
||||
Mod modtype extend open flags defs -> prPrec i 0 (concat [prt 0 modtype , ["="] , prt 0 extend , prt 0 open , ["{"] , prt 0 flags , prt 0 defs , ["}"]])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
x:xs -> (concat [prt 0 x , prt 0 xs])
|
||||
|
||||
instance Print ModType where
|
||||
prt i e = case e of
|
||||
MTAbs id -> prPrec i 0 (concat [["abstract"] , prt 0 id])
|
||||
MTCnc id0 id -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id])
|
||||
MTRes id -> prPrec i 0 (concat [["resource"] , prt 0 id])
|
||||
|
||||
|
||||
instance Print Extend where
|
||||
prt i e = case e of
|
||||
Ext id -> prPrec i 0 (concat [prt 0 id , ["**"]])
|
||||
NoExt -> prPrec i 0 (concat [])
|
||||
|
||||
|
||||
instance Print Open where
|
||||
prt i e = case e of
|
||||
NoOpens -> prPrec i 0 (concat [])
|
||||
Opens ids -> prPrec i 0 (concat [["open"] , prt 0 ids , ["in"]])
|
||||
|
||||
|
||||
instance Print Flag where
|
||||
prt i e = case e of
|
||||
Flg id0 id -> prPrec i 0 (concat [["flags"] , prt 0 id0 , ["="] , prt 0 id])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
|
||||
|
||||
instance Print Def where
|
||||
prt i e = case e of
|
||||
AbsDCat id decls cidents -> prPrec i 0 (concat [["cat"] , prt 0 id , ["["] , prt 0 decls , ["]"] , ["="] , prt 0 cidents])
|
||||
AbsDFun id exp0 exp -> prPrec i 0 (concat [["fun"] , prt 0 id , [":"] , prt 0 exp0 , ["="] , prt 0 exp])
|
||||
ResDPar id pardefs -> prPrec i 0 (concat [["param"] , prt 0 id , ["="] , prt 0 pardefs])
|
||||
ResDOper id ctype term -> prPrec i 0 (concat [["oper"] , prt 0 id , [":"] , prt 0 ctype , ["="] , prt 0 term])
|
||||
CncDCat id ctype term0 term -> prPrec i 0 (concat [["lincat"] , prt 0 id , ["="] , prt 0 ctype , ["="] , prt 0 term0 , [";"] , prt 0 term])
|
||||
CncDFun id cident argvars term0 term -> prPrec i 0 (concat [["lin"] , prt 0 id , [":"] , prt 0 cident , ["="] , ["\\"] , prt 0 argvars , ["->"] , prt 0 term0 , [";"] , prt 0 term])
|
||||
AnyDInd id0 status id -> prPrec i 0 (concat [prt 0 id0 , prt 0 status , ["in"] , prt 0 id])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
x:xs -> (concat [prt 0 x , [";","NEW"] , prt 0 xs]) --H
|
||||
|
||||
instance Print ParDef where
|
||||
prt i e = case e of
|
||||
ParD id ctypes -> prPrec i 0 (concat [prt 0 id , prt 0 ctypes])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
[x] -> (concat [prt 0 x])
|
||||
x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])
|
||||
|
||||
instance Print Status where
|
||||
prt i e = case e of
|
||||
Canon -> prPrec i 0 (concat [["data"]])
|
||||
NonCan -> prPrec i 0 (concat [])
|
||||
|
||||
|
||||
instance Print CIdent where
|
||||
prt i e = case e of
|
||||
CIQ id0 id -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
x:xs -> (concat [prt 0 x , prt 0 xs])
|
||||
|
||||
instance Print Exp where
|
||||
prt i e = case e of
|
||||
EApp exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , prt 2 exp])
|
||||
EProd id exp0 exp -> prPrec i 0 (concat [["("] , prt 0 id , [":"] , prt 0 exp0 , [")"] , ["->"] , prt 0 exp])
|
||||
EAtom atom -> prPrec i 2 (concat [prt 0 atom])
|
||||
EAbs id exp -> prPrec i 0 (concat [["\\"] , prt 0 id , ["->"] , prt 0 exp])
|
||||
EEq equations -> prPrec i 0 (concat [["{"] , prt 0 equations , ["}"]])
|
||||
|
||||
instance Print Sort where
|
||||
prt i e = case e of
|
||||
SType -> prPrec i 0 (concat [["Type"]])
|
||||
|
||||
instance Print Equation where
|
||||
prt i e = case e of
|
||||
Equ apatts exp -> prPrec i 0 (concat [prt 0 apatts , ["->"] , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
|
||||
|
||||
instance Print APatt where
|
||||
prt i e = case e of
|
||||
APC cident apatts -> prPrec i 0 (concat [["("] , prt 0 cident , prt 0 apatts , [")"]])
|
||||
APV id -> prPrec i 0 (concat [prt 0 id])
|
||||
APS str -> prPrec i 0 (concat [prt 0 str])
|
||||
API n -> prPrec i 0 (concat [prt 0 n])
|
||||
APW -> prPrec i 0 (concat [["_"]])
|
||||
|
||||
prtList es = case es of
|
||||
[x] -> (concat [prt 0 x])
|
||||
x:xs -> (concat [prt 0 x , prt 0 xs])
|
||||
|
||||
instance Print Atom where
|
||||
prt i e = case e of
|
||||
AC cident -> prPrec i 0 (concat [prt 0 cident])
|
||||
AD cident -> prPrec i 0 (concat [["<"] , prt 0 cident , [">"]])
|
||||
AV id -> prPrec i 0 (concat [["$"] , prt 0 id])
|
||||
AM n -> prPrec i 0 (concat [["?"] , prt 0 n])
|
||||
AS str -> prPrec i 0 (concat [prt 0 str])
|
||||
AI n -> prPrec i 0 (concat [prt 0 n])
|
||||
AT sort -> prPrec i 0 (concat [prt 0 sort])
|
||||
|
||||
|
||||
instance Print Decl where
|
||||
prt i e = case e of
|
||||
Decl id exp -> prPrec i 0 (concat [prt 0 id , [":"] , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
[x] -> (concat [prt 0 x])
|
||||
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
|
||||
|
||||
instance Print CType where
|
||||
prt i e = case e of
|
||||
RecType labellings -> prPrec i 0 (concat [["{"] , prt 0 labellings , ["}"]])
|
||||
Table ctype0 ctype -> prPrec i 0 (concat [["("] , prt 0 ctype0 , ["=>"] , prt 0 ctype , [")"]])
|
||||
Cn cident -> prPrec i 0 (concat [prt 0 cident])
|
||||
TStr -> prPrec i 0 (concat [["Str"]])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
x:xs -> (concat [prt 0 x , prt 0 xs])
|
||||
|
||||
instance Print Labelling where
|
||||
prt i e = case e of
|
||||
Lbg label ctype -> prPrec i 0 (concat [prt 0 label , [":"] , prt 0 ctype])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
[x] -> (concat [prt 0 x])
|
||||
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
|
||||
|
||||
instance Print Term where
|
||||
prt i e = case e of
|
||||
Arg argvar -> prPrec i 2 (concat [prt 0 argvar])
|
||||
I cident -> prPrec i 2 (concat [prt 0 cident])
|
||||
Con cident terms -> prPrec i 2 (concat [["<"] , prt 0 cident , prt 2 terms , [">"]])
|
||||
LI id -> prPrec i 2 (concat [["$"] , prt 0 id])
|
||||
R assigns -> prPrec i 2 (concat [["{"] , prt 0 assigns , ["}"]])
|
||||
P term label -> prPrec i 1 (concat [prt 2 term , ["."] , prt 0 label])
|
||||
T ctype cases -> prPrec i 1 (concat [["table"] , prt 0 ctype , ["{"] , prt 0 cases , ["}"]])
|
||||
S term0 term -> prPrec i 1 (concat [prt 1 term0 , ["!"] , prt 2 term])
|
||||
C term0 term -> prPrec i 0 (concat [prt 0 term0 , ["++"] , prt 1 term])
|
||||
FV terms -> prPrec i 1 (concat [["variants"] , ["{"] , prt 2 terms , ["}"]])
|
||||
K tokn -> prPrec i 2 (concat [prt 0 tokn])
|
||||
E -> prPrec i 2 (concat [["["] , ["]"]])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
x:xs -> (concat [prt 2 x , prt 2 xs])
|
||||
|
||||
instance Print Tokn where
|
||||
prt i e = case e of
|
||||
KS str -> prPrec i 0 (concat [prt 0 str])
|
||||
KP strs variants -> prPrec i 0 (concat [["["] , ["pre"] , prt 0 strs , ["{"] , prt 0 variants , ["}"] , ["]"]])
|
||||
|
||||
|
||||
instance Print Assign where
|
||||
prt i e = case e of
|
||||
Ass label term -> prPrec i 0 (concat [prt 0 label , ["="] , prt 0 term])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
[x] -> (concat [prt 0 x])
|
||||
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
|
||||
|
||||
instance Print Case where
|
||||
prt i e = case e of
|
||||
Cas patts term -> prPrec i 0 (concat [prt 0 patts , ["=>"] , prt 0 term])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
[x] -> (concat [prt 0 x])
|
||||
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
|
||||
|
||||
instance Print Variant where
|
||||
prt i e = case e of
|
||||
Var strs0 strs -> prPrec i 0 (concat [prt 0 strs0 , ["/"] , prt 0 strs])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
[x] -> (concat [prt 0 x])
|
||||
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
|
||||
|
||||
instance Print Label where
|
||||
prt i e = case e of
|
||||
L id -> prPrec i 0 (concat [prt 0 id])
|
||||
LV n -> prPrec i 0 (concat [["$"] , prt 0 n])
|
||||
|
||||
|
||||
instance Print ArgVar where
|
||||
prt i e = case e of
|
||||
A id n -> prPrec i 0 (concat [prt 0 id , ["@"] , prt 0 n])
|
||||
AB id n0 n -> prPrec i 0 (concat [prt 0 id , ["+"] , prt 0 n0 , ["@"] , prt 0 n])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
[x] -> (concat [prt 0 x])
|
||||
x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
|
||||
|
||||
instance Print Patt where
|
||||
prt i e = case e of
|
||||
PC cident patts -> prPrec i 0 (concat [["("] , prt 0 cident , prt 0 patts , [")"]])
|
||||
PV id -> prPrec i 0 (concat [prt 0 id])
|
||||
PW -> prPrec i 0 (concat [["_"]])
|
||||
PR pattassigns -> prPrec i 0 (concat [["{"] , prt 0 pattassigns , ["}"]])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
x:xs -> (concat [prt 0 x , prt 0 xs])
|
||||
|
||||
instance Print PattAssign where
|
||||
prt i e = case e of
|
||||
PAss label patt -> prPrec i 0 (concat [prt 0 label , ["="] , prt 0 patt])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concat [])
|
||||
[x] -> (concat [prt 0 x])
|
||||
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
|
||||
|
||||
|
||||
Reference in New Issue
Block a user