From f85232947e74ee7ef8c7b0ad2338212e7e68f1be Mon Sep 17 00:00:00 2001 From: krasimir Date: Sun, 13 Dec 2009 18:50:29 +0000 Subject: reorganize the directories under src, and rescue the JavaScript interpreter from deprecated --- src/GF/Grammar/Printer.hs | 317 ---------------------------------------------- 1 file changed, 317 deletions(-) delete mode 100644 src/GF/Grammar/Printer.hs (limited to 'src/GF/Grammar/Printer.hs') diff --git a/src/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs deleted file mode 100644 index 06cac9705..000000000 --- a/src/GF/Grammar/Printer.hs +++ /dev/null @@ -1,317 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Grammar.Printer --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- ------------------------------------------------------------------------------ - -module GF.Grammar.Printer - ( TermPrintQual(..) - , ppIdent - , ppLabel - , ppModule - , ppJudgement - , ppTerm - , ppTermTabular - , ppPatt - , ppValue - , ppConstrs - - , showTerm, TermPrintStyle(..) - ) where - -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Infra.Option -import GF.Grammar.Values -import GF.Grammar.Grammar -import GF.Data.Operations -import Text.PrettyPrint - -import Data.Maybe (maybe) -import Data.List (intersperse) - -data TermPrintQual = Qualified | Unqualified - -ppModule :: TermPrintQual -> SourceModule -> Doc -ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments _) = - hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr - where - defs = tree2list jments - - hdr = complModDoc <+> modTypeDoc <+> equals <+> - hsep (intersperse (text "**") $ - filter (not . isEmpty) $ [ commaPunct ppExtends exts - , maybe empty ppWith with - , if null opens - then lbrace - else text "open" <+> commaPunct ppOpenSpec opens <+> text "in" <+> lbrace - ]) - - ftr = rbrace - - complModDoc = - case mstat of - MSComplete -> empty - MSIncomplete -> text "incomplete" - - modTypeDoc = - case mtype of - MTAbstract -> text "abstract" <+> ppIdent mn - MTResource -> text "resource" <+> ppIdent mn - MTConcrete abs -> text "concrete" <+> ppIdent mn <+> text "of" <+> ppIdent abs - MTInterface -> text "interface" <+> ppIdent mn - MTInstance int -> text "instance" <+> ppIdent mn <+> text "of" <+> ppIdent int - - ppExtends (id,MIAll ) = ppIdent id - ppExtends (id,MIOnly incs) = ppIdent id <+> brackets (commaPunct ppIdent incs) - ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs) - - ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppInstSpec opens - -ppOptions opts = - text "flags" $$ - nest 2 (vcat [text option <+> equals <+> str value <+> semi | (option,value) <- optionsGFO opts]) - -ppJudgement q (id, AbsCat pcont pconstrs) = - text "cat" <+> ppIdent id <+> - (case pcont of - Just cont -> hsep (map (ppDecl q) cont) - Nothing -> empty) <+> semi $$ - case pconstrs of - Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm q 0) costrs)) <+> semi - Nothing -> empty -ppJudgement q (id, AbsFun ptype _ pexp) = - (case ptype of - Just typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi - Nothing -> empty) $$ - (case pexp of - Just [] -> empty - Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | (ps,e) <- eqs] - Nothing -> empty) -ppJudgement q (id, ResParam pparams _) = - text "param" <+> ppIdent id <+> - (case pparams of - Just ps -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps)) - _ -> empty) <+> semi -ppJudgement q (id, ResValue pvalue) = empty -ppJudgement q (id, ResOper ptype pexp) = - text "oper" <+> ppIdent id <+> - (case ptype of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} $$ - case pexp of {Just e -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi -ppJudgement q (id, ResOverload ids defs) = - text "oper" <+> ppIdent id <+> equals <+> - (text "overload" <+> lbrace $$ - nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (ty,e) <- defs]) $$ - rbrace) <+> semi -ppJudgement q (id, CncCat ptype pexp pprn) = - (case ptype of - Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi - Nothing -> empty) $$ - (case pexp of - Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi - Nothing -> empty) $$ - (case pprn of - Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi - Nothing -> empty) -ppJudgement q (id, CncFun ptype pdef pprn) = - (case pdef of - Just e -> let (xs,e') = getAbs e - in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi - Nothing -> empty) $$ - (case pprn of - Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi - Nothing -> empty) -ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi - -ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e) - in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e') -ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of - ([],_) -> text "table" <+> lbrace $$ - nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ - rbrace - (vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm q 0 e) -ppTerm q d (T (TTyped t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ - nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ - rbrace -ppTerm q d (T (TComp t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ - nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ - rbrace -ppTerm q d (T (TWild t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ - nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ - rbrace -ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit - then prec d 0 (ppTerm q 4 a <+> text "->" <+> ppTerm q 0 b) - else prec d 0 (parens (ppBind (bt,x) <+> colon <+> ppTerm q 0 a) <+> text "->" <+> ppTerm q 0 b) -ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> text "=>" <+> ppTerm q 0 vt) -ppTerm q d (Let l e) = let (ls,e') = getLet e - in prec d 0 (text "let" <+> vcat (map (ppLocDef q) (l:ls)) $$ text "in" <+> ppTerm q 0 e') -ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> str s) -ppTerm q d (C e1 e2) =prec d 1 (ppTerm q 2 e1 <+> text "++" <+> ppTerm q 1 e2) -ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+' <+> ppTerm q 2 e2) -ppTerm q d (S x y) = case x of - T annot xs -> let e = case annot of - TRaw -> y - TTyped t -> Typed y t - TComp t -> Typed y t - TWild t -> Typed y t - in text "case" <+> ppTerm q 0 e <+> text "of" <+> lbrace $$ - nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ - rbrace - _ -> prec d 3 (ppTerm q 3 x <+> text "!" <+> ppTerm q 4 y) -ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> text "**" <+> ppTerm q 4 y) -ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y) -ppTerm q d (V e es) = text "table" <+> ppTerm q 6 e <+> lbrace $$ - nest 2 (fsep (punctuate semi (map (ppTerm q 0) es))) $$ - rbrace -ppTerm q d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es))) -ppTerm q d (Alts (e,xs))=text "pre" <+> braces (ppTerm q 0 e <> semi <+> fsep (punctuate semi (map (ppAltern q) xs))) -ppTerm q d (Strs es) = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es))) -ppTerm q d (EPatt p) = prec d 4 (char '#' <+> ppPatt q 2 p) -ppTerm q d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm q 0 t) -ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> char '.' <> ppLabel l) -ppTerm q d (Cn id) = ppIdent id -ppTerm q d (Vr id) = ppIdent id -ppTerm q d (Q m id) = ppQIdent q m id -ppTerm q d (QC m id) = ppQIdent q m id -ppTerm q d (Sort id) = ppIdent id -ppTerm q d (K s) = str s -ppTerm q d (EInt n) = integer n -ppTerm q d (EFloat f) = double f -ppTerm q d (Meta _) = char '?' -ppTerm q d (Empty) = text "[]" -ppTerm q d (R xs) = braces (fsep (punctuate semi [ppLabel l <+> - fsep [case mb_t of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty}, - equals <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs])) -ppTerm q d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm q 0 t | (l,t) <- xs])) -ppTerm q d (Typed e t) = char '<' <> ppTerm q 0 e <+> colon <+> ppTerm q 0 t <> char '>' - -ppTermTabular :: TermPrintQual -> Term -> [(Doc,Doc)] -ppTermTabular q = pr where - pr t = case t of - R rs -> - [(ppLabel lab <+> char '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val] - T _ cs -> - [(ppPatt q 0 patt <+> text "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val] - V _ cs -> - [(char '#' <> int i <+> text "=>" <+> path, str) | (i, val ) <- zip [0..] cs, (path,str) <- pr val] - _ -> [(empty,ps t)] - ps t = case t of - K s -> text s - C s u -> ps s <+> ps u - FV ts -> hsep (intersperse (char '/') (map ps ts)) - _ -> ppTerm q 0 t - -ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e - -ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> ppTerm q 0 e - -ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '|' <+> ppPatt q 1 p2) -ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2) -ppPatt q d (PC f ps) = if null ps - then ppIdent f - else prec d 1 (ppIdent f <+> hsep (map (ppPatt q 2) ps)) -ppPatt q d (PP f g ps) = if null ps - then ppQIdent q f g - else prec d 1 (ppQIdent q f g <+> hsep (map (ppPatt q 2) ps)) -ppPatt q d (PRep p) = prec d 1 (ppPatt q 2 p <> char '*') -ppPatt q d (PAs f p) = prec d 1 (ppIdent f <> char '@' <> ppPatt q 2 p) -ppPatt q d (PNeg p) = prec d 1 (char '-' <> ppPatt q 2 p) -ppPatt q d (PChar) = char '?' -ppPatt q d (PChars s) = brackets (str s) -ppPatt q d (PMacro id) = char '#' <> ppIdent id -ppPatt q d (PM m id) = char '#' <> ppIdent m <> char '.' <> ppIdent id -ppPatt q d PW = char '_' -ppPatt q d (PV id) = ppIdent id -ppPatt q d (PInt n) = integer n -ppPatt q d (PFloat f) = double f -ppPatt q d (PString s) = str s -ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs])) - -ppValue :: TermPrintQual -> Int -> Val -> Doc -ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging -ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v) -ppValue q d (VCn (_,c)) = ppIdent c -ppValue q d (VClos env e) = case e of - Meta _ -> ppTerm q d e <> ppEnv env - _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging -ppValue q d (VRecType xs) = braces (hsep (punctuate comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs])) -ppValue q d VType = text "Type" - -ppConstrs :: Constraints -> [Doc] -ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w)) - -ppEnv :: Env -> Doc -ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e) - -str s = doubleQuotes (text s) - -ppDecl q (_,id,typ) - | id == identW = ppTerm q 4 typ - | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ) - -ppDDecl q (_,id,typ) - | id == identW = ppTerm q 6 typ - | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ) - -ppIdent = text . showIdent - -ppQIdent q m id = - case q of - Qualified -> ppIdent m <> char '.' <> ppIdent id - Unqualified -> ppIdent id - -ppLabel = ppIdent . label2ident - -ppOpenSpec (OSimple id) = ppIdent id -ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n) - -ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n) - -ppLocDef q (id, (mbt, e)) = - ppIdent id <+> - (case mbt of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} <+> equals <+> ppTerm q 0 e) <+> semi - -ppBind (Explicit,v) = ppIdent v -ppBind (Implicit,v) = braces (ppIdent v) - -ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y - -ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt) - -commaPunct f ds = (hcat (punctuate comma (map f ds))) - -prec d1 d2 doc - | d1 > d2 = parens doc - | otherwise = doc - -getAbs :: Term -> ([(BindType,Ident)], Term) -getAbs (Abs bt v e) = let (xs,e') = getAbs e - in ((bt,v):xs,e') -getAbs e = ([],e) - -getCTable :: Term -> ([Ident], Term) -getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e - in (v:vs,e') -getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e - in (identW:vs,e') -getCTable e = ([],e) - -getLet :: Term -> ([LocalDef], Term) -getLet (Let l e) = let (ls,e') = getLet e - in (l:ls,e') -getLet e = ([],e) - -showTerm :: TermPrintStyle -> TermPrintQual -> Term -> String -showTerm style q t = render $ - case style of - TermPrintTable -> vcat [p <+> s | (p,s) <- ppTermTabular q t] - TermPrintAll -> vcat [ s | (p,s) <- ppTermTabular q t] - TermPrintDefault -> ppTerm q 0 t - -data TermPrintStyle - = TermPrintTable - | TermPrintAll - | TermPrintDefault -- cgit v1.2.3