forked from GitHub/gf-core
190 lines
5.0 KiB
Haskell
190 lines
5.0 KiB
Haskell
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
|