Founding the newly structured GF2.0 cvs archive.

1 files changed, 319 insertions, 0 deletions

diff --git a/src/GF/Canon/PrintGFC.hs b/src/GF/Canon/PrintGFC.hs
new file mode 100644
index 000000000..c4f2e7d62
--- /dev/null
+++ b/src/GF/Canon/PrintGFC.hs
@@ -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])
+
+