Founding the newly structured GF2.0 cvs archive.

src/GF/Grammar/PrGrammar.hs

@@ -0,0 +1,189 @@
+module PrGrammar where
+
+import Operations
+import Zipper
+import Grammar
+import Modules
+import qualified PrintGF as P
+import qualified PrintGFC as C
+import qualified AbsGFC as A
+import Values
+import GrammarToSource
+import Ident
+import Str
+
+import List (intersperse)
+
+-- AR 7/12/1999 - 1/4/2000 - 10/5/2003
+
+-- printing and prettyprinting class
+
+class Print a where
+  prt  :: a -> String
+  prt2 :: a -> String   -- printing with parentheses, if needed
+  prpr :: a -> [String] -- pretty printing
+  prt_ :: a -> String   -- printing without ident qualifications
+  prt2 = prt
+  prt_ = prt
+  prpr = return . prt
+
+-- to show terms etc in error messages
+prtBad :: Print a => String -> a -> Err b
+prtBad s a = Bad (s +++ prt a)
+
+prGrammar = P.printTree . trGrammar
+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]
+
+-- some GFC notions
+
+instance Print A.Exp where prt = C.printTree
+instance Print A.Term where prt = C.printTree
+instance Print A.Patt where prt = C.printTree
+instance Print A.Case where prt = C.printTree
+instance Print A.Atom where prt = C.printTree
+instance Print A.CIdent where prt = C.printTree
+instance Print A.CType where prt = C.printTree
+instance Print A.Label where prt = C.printTree
+instance Print A.Module where prt = C.printTree
+instance Print A.Sort where prt = C.printTree
+
+
+-- 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
+
+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))
+
+--- to get rig of brackets
+prRefinement :: Term -> String
+prRefinement t = case t of
+  Q m c  -> prQIdent (m,c)
+  QC m c -> prQIdent (m,c)
+  _ -> prt t
+
+-- a pretty-printer for parsable output
+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
+ 
+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) = s
+  prt (AtI i) = show i
+
+prQIdent :: QIdent -> String
+prQIdent (m,f) = prt m ++ "." ++ 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