From 9190efdd62b306179ac930f988f8d30cd84e8d4b Mon Sep 17 00:00:00 2001 From: krasimir Date: Wed, 4 Mar 2009 13:41:33 +0000 Subject: [PATCH] qualified/unqualified mode for GF.Grammar.Printer. Used in the "cc" command --- src/GF/Compile.hs | 16 +-- src/GF/Compile/Update.hs | 8 +- src/GF/Grammar/API.hs | 39 ++---- src/GF/Grammar/Printer.hs | 261 +++++++++++++++++++++----------------- src/GFI.hs | 17 ++- 5 files changed, 180 insertions(+), 161 deletions(-) diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs index 70c36aa76..529a7b700 100644 --- a/src/GF/Compile.hs +++ b/src/GF/Compile.hs @@ -151,7 +151,7 @@ compileOne opts env@(_,srcgr,_) file = do sm00 <- putPointE Normal opts ("+ reading" +++ file) $ ioeIO (decodeFile file) let sm0 = addOptionsToModule opts sm00 - intermOut opts DumpSource (ppModule sm0) + intermOut opts DumpSource (ppModule Qualified sm0) let sm1 = unsubexpModule sm0 sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule mos sm1 @@ -171,7 +171,7 @@ compileOne opts env@(_,srcgr,_) file = do getSourceModule opts file let sm0 = decodeStringsInModule sm00 - intermOut opts DumpSource (ppModule sm0) + intermOut opts DumpSource (ppModule Qualified sm0) (k',sm) <- compileSourceModule opts env sm0 let sm1 = if isConcr sm then shareModule sm else sm -- cannot expand Str @@ -189,28 +189,28 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do mos = modules gr mo1 <- ioeErr $ rebuildModule mos mo - intermOut opts DumpRebuild (ppModule mo1) + intermOut opts DumpRebuild (ppModule Qualified mo1) mo1b <- ioeErr $ extendModule mos mo1 - intermOut opts DumpExtend (ppModule mo1b) + intermOut opts DumpExtend (ppModule Qualified mo1b) case mo1b of (_,n) | not (isCompleteModule n) -> do return (k,mo1b) -- refresh would fail, since not renamed _ -> do mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b - intermOut opts DumpRename (ppModule mo2) + intermOut opts DumpRename (ppModule Qualified mo2) (mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2 if null warnings then return () else putp warnings $ return () - intermOut opts DumpTypeCheck (ppModule mo3) + intermOut opts DumpTypeCheck (ppModule Qualified mo3) (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 - intermOut opts DumpRefresh (ppModule mo3r) + intermOut opts DumpRefresh (ppModule Qualified mo3r) let eenv = () --- emptyEEnv (mo4,eenv') <- putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r - intermOut opts DumpOptimize (ppModule mo4) + intermOut opts DumpOptimize (ppModule Qualified mo4) return (k',mo4) diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs index 4bcea0db2..ba0f383a8 100644 --- a/src/GF/Compile/Update.hs +++ b/src/GF/Compile/Update.hs @@ -37,9 +37,9 @@ buildAnyTree m = go Map.empty Just i -> case unifyAnyInfo c i j of Ok k -> go (Map.insert c k map) is Bad _ -> fail $ render (text "cannot unify the informations" $$ - nest 4 (ppJudgement (c,i)) $$ + nest 4 (ppJudgement Qualified (c,i)) $$ text "and" $+$ - nest 4 (ppJudgement (c,j)) $$ + nest 4 (ppJudgement Qualified (c,j)) $$ text "in module" <+> ppIdent m) Nothing -> go (Map.insert c j map) is @@ -143,9 +143,9 @@ extendMod isCompl (name,cond) base old new = foldM try new $ Map.toList old Just j -> case unifyAnyInfo c i j of Ok k -> return $ updateTree (c,k) new Bad _ -> fail $ render (text "cannot unify the information" $$ - nest 4 (ppJudgement (c,i)) $$ + nest 4 (ppJudgement Qualified (c,i)) $$ text "in module" <+> ppIdent name <+> text "with" $$ - nest 4 (ppJudgement (c,j)) $$ + nest 4 (ppJudgement Qualified (c,j)) $$ text "in module" <+> ppIdent base) Nothing -> if isCompl then return $ updateTree (c,indirInfo name i) new diff --git a/src/GF/Grammar/API.hs b/src/GF/Grammar/API.hs index 182b5e94e..76508d963 100644 --- a/src/GF/Grammar/API.hs +++ b/src/GF/Grammar/API.hs @@ -2,12 +2,11 @@ module GF.Grammar.API ( Grammar, emptyGrammar, pTerm, - prTerm, + ppTerm, checkTerm, computeTerm, showTerm, - TermPrintStyle(..), - pTermPrintStyle + TermPrintStyle(..), TermPrintQual(..), ) where import GF.Source.ParGF @@ -17,7 +16,7 @@ import GF.Infra.Ident import GF.Infra.Modules (greatestResource) import GF.Compile.GetGrammar import GF.Grammar.Macros -import GF.Grammar.PrGrammar +import GF.Grammar.Printer import GF.Compile.Rename (renameSourceTerm) import GF.Compile.CheckGrammar (justCheckLTerm) @@ -27,6 +26,7 @@ import GF.Data.Operations import GF.Infra.Option import qualified Data.ByteString.Char8 as BS +import Text.PrettyPrint type Grammar = SourceGrammar @@ -38,9 +38,6 @@ pTerm s = do e <- pExp $ myLexer (BS.pack s) transExp e -prTerm :: Term -> String -prTerm = prt - checkTerm :: Grammar -> Term -> Err Term checkTerm gr t = do mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr @@ -54,22 +51,14 @@ checkTermAny gr m t = do computeTerm :: Grammar -> Term -> Err Term computeTerm = computeConcrete -showTerm :: TermPrintStyle -> Term -> String -showTerm style t = - case style of - TermPrintTable -> unlines [p +++ s | (p,s) <- prTermTabular t] - TermPrintAll -> unlines [ s | (p,s) <- prTermTabular t] - TermPrintUnqual -> prt_ t - TermPrintDefault -> prt t - - -data TermPrintStyle = TermPrintTable | TermPrintAll | TermPrintUnqual | TermPrintDefault - deriving (Show,Eq) - -pTermPrintStyle s = case s of - "table" -> TermPrintTable - "all" -> TermPrintAll - "unqual" -> TermPrintUnqual - _ -> TermPrintDefault - +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 diff --git a/src/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs index c73e6b092..f3a19cd4b 100644 --- a/src/GF/Grammar/Printer.hs +++ b/src/GF/Grammar/Printer.hs @@ -8,10 +8,12 @@ ----------------------------------------------------------------------------- module GF.Grammar.Printer - ( ppIdent + ( TermPrintQual(..) + , ppIdent , ppModule , ppJudgement , ppTerm + , ppTermTabular , ppPatt ) where @@ -25,9 +27,11 @@ import Text.PrettyPrint import Data.Maybe (maybe) import Data.List (intersperse) -ppModule :: SourceModule -> Doc -ppModule (mn, ModInfo mtype mstat opts exts with opens _ jments _) = - hdr $$ nest 2 (ppOptions opts $$ vcat (map ppJudgement defs)) $$ ftr +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 @@ -66,153 +70,174 @@ ppOptions opts = text "flags" $$ nest 2 (vcat [text option <+> equals <+> text (show value) <+> semi | (option,value) <- optionsGFO opts]) -ppJudgement (id, AbsCat pcont pconstrs) = +ppJudgement q (id, AbsCat pcont pconstrs) = text "cat" <+> ppIdent id <+> (case pcont of - Just cont -> hsep (map ppDecl cont) + 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 0) costrs)) <+> semi + Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm q 0) costrs)) <+> semi Nothing -> empty -ppJudgement (id, AbsFun ptype pexp) = +ppJudgement q (id, AbsFun ptype pexp) = (case ptype of - Just typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm 0 typ <+> semi + Just typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi Nothing -> empty) $$ (case pexp of Just EData -> empty - Just (Eqs [(ps,e)]) -> text "def" <+> ppIdent id <+> hcat (map (ppPatt 2) ps) <+> equals <+> ppTerm 0 e <+> semi - Just exp -> text "def" <+> ppIdent id <+> equals <+> ppTerm 0 exp <+> semi + Just (Eqs [(ps,e)]) -> text "def" <+> ppIdent id <+> hcat (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi + Just exp -> text "def" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi Nothing -> empty) -ppJudgement (id, ResParam pparams) = +ppJudgement q (id, ResParam pparams) = text "param" <+> ppIdent id <+> (case pparams of - Just (ps,_) -> equals <+> fsep (intersperse (char '|') (map ppParam ps)) + Just (ps,_) -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps)) _ -> empty) <+> semi -ppJudgement (id, ResValue pvalue) = empty -ppJudgement (id, ResOper ptype pexp) = +ppJudgement q (id, ResValue pvalue) = empty +ppJudgement q (id, ResOper ptype pexp) = text "oper" <+> ppIdent id <+> - (case ptype of {Just t -> colon <+> ppTerm 0 t; Nothing -> empty} $$ - case pexp of {Just e -> equals <+> ppTerm 0 e; Nothing -> empty}) <+> semi -ppJudgement (id, ResOverload ids defs) = + (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 0 ty $$ equals <+> ppTerm 0 e) | (ty,e) <- defs]) $$ + nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (ty,e) <- defs]) $$ rbrace) <+> semi -ppJudgement (id, CncCat ptype pexp pprn) = +ppJudgement q (id, CncCat ptype pexp pprn) = (case ptype of - Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm 0 typ <+> semi + 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 0 exp <+> semi + 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 0 prn <+> semi + Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi Nothing -> empty) -ppJudgement (id, CncFun ptype pdef pprn) = +ppJudgement q (id, CncFun ptype pdef pprn) = (case pdef of Just e -> let (vs,e') = getAbs e - in text "lin" <+> ppIdent id <+> hsep (map ppIdent vs) <+> equals <+> ppTerm 0 e' <+> semi + in text "lin" <+> ppIdent id <+> hsep (map ppIdent vs) <+> equals <+> ppTerm q 0 e' <+> semi Nothing -> empty) $$ (case pprn of - Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm 0 prn <+> semi + Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi Nothing -> empty) -ppJudgement (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid +ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid -ppTerm d (Abs v e) = let (vs,e') = getAbs e - in prec d 0 (char '\\' <> commaPunct ppIdent (v:vs) <+> text "->" <+> ppTerm 0 e') -ppTerm d (T TRaw xs) = case getCTable (T TRaw xs) of - ([],_) -> text "table" <+> lbrace $$ - nest 2 (vcat (punctuate semi (map ppCase xs))) $$ - rbrace - (vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm 0 e) -ppTerm d (T (TTyped t) xs) = text "table" <+> ppTerm 0 t <+> lbrace $$ - nest 2 (vcat (punctuate semi (map ppCase xs))) $$ - rbrace -ppTerm d (T (TComp t) xs) = text "table" <+> ppTerm 0 t <+> lbrace $$ - nest 2 (vcat (punctuate semi (map ppCase xs))) $$ - rbrace -ppTerm d (T (TWild t) xs) = text "table" <+> ppTerm 0 t <+> lbrace $$ - nest 2 (vcat (punctuate semi (map ppCase xs))) $$ - rbrace -ppTerm d (Prod x a b)= if x == identW - then prec d 0 (ppTerm 4 a <+> text "->" <+> ppTerm 0 b) - else prec d 0 (parens (ppIdent x <+> colon <+> ppTerm 0 a) <+> text "->" <+> ppTerm 0 b) -ppTerm d (Table kt vt)=prec d 0 (ppTerm 3 kt <+> text "=>" <+> ppTerm 0 vt) -ppTerm d (Let l e) = let (ls,e') = getLet e - in prec d 0 (text "let" <+> vcat (map ppLocDef (l:ls)) $$ text "in" <+> ppTerm 0 e') -ppTerm d (Eqs es) = text "fn" <+> lbrace $$ - nest 2 (vcat (map (\e -> ppEquation e <+> semi) es)) $$ - rbrace -ppTerm d (Example e s)=prec d 0 (text "in" <+> ppTerm 5 e <+> text (show s)) -ppTerm d (C e1 e2) = prec d 1 (ppTerm 2 e1 <+> text "++" <+> ppTerm 1 e2) -ppTerm d (Glue e1 e2)= prec d 2 (ppTerm 3 e1 <+> char '+' <+> ppTerm 2 e2) -ppTerm d (S x y) = case x of - T annot xs -> let e = case annot of - TTyped t -> Typed y t - TRaw -> y - in text "case" <+> ppTerm 0 e <+> text "of" <+> lbrace $$ - nest 2 (vcat (punctuate semi (map ppCase xs))) $$ - rbrace - _ -> prec d 3 (ppTerm 3 x <+> text "!" <+> ppTerm 4 y) -ppTerm d (ExtR x y) = prec d 3 (ppTerm 3 x <+> text "**" <+> ppTerm 4 y) -ppTerm d (App x y) = prec d 4 (ppTerm 4 x <+> ppTerm 5 y) -ppTerm d (V e es) = text "table" <+> ppTerm 6 e <+> lbrace $$ - nest 2 (fsep (punctuate semi (map (ppTerm 0) es))) $$ - rbrace -ppTerm d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm 0) es))) -ppTerm d (Alts (e,xs))=text "pre" <+> braces (ppTerm 0 e <> semi <+> fsep (punctuate semi (map ppAltern xs))) -ppTerm d (Strs es) = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm 0) es))) -ppTerm d (EPatt p) = prec d 4 (char '#' <+> ppPatt 2 p) -ppTerm d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm 0 t) -ppTerm d (P t l) = prec d 5 (ppTerm 5 t <> char '.' <> ppLabel l) -ppTerm d (Cn id) = ppIdent id -ppTerm d (Vr id) = ppIdent id -ppTerm d (Q m id) = ppIdent m <> char '.' <> ppIdent id -ppTerm d (QC m id) = ppIdent m <> char '.' <> ppIdent id -ppTerm d (Sort id) = ppIdent id -ppTerm d (K s) = text (show s) -ppTerm d (EInt n) = integer n -ppTerm d (EFloat f) = double f -ppTerm d (Meta _) = char '?' -ppTerm d (Empty) = text "[]" -ppTerm d (EData) = text "data" -ppTerm d (R xs) = braces (fsep (punctuate semi [ppLabel l <+> - fsep [case mb_t of {Just t -> colon <+> ppTerm 0 t; Nothing -> empty}, - equals <+> ppTerm 0 e] | (l,(mb_t,e)) <- xs])) -ppTerm d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm 0 t | (l,t) <- xs])) -ppTerm d (Typed e t) = char '<' <> ppTerm 0 e <+> colon <+> ppTerm 0 t <> char '>' +ppTerm q d (Abs v e) = let (vs,e') = getAbs e + in prec d 0 (char '\\' <> commaPunct ppIdent (v:vs) <+> 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 x a b)= if x == identW + then prec d 0 (ppTerm q 4 a <+> text "->" <+> ppTerm q 0 b) + else prec d 0 (parens (ppIdent 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 (Eqs es) = text "fn" <+> lbrace $$ + nest 2 (vcat (map (\e -> ppEquation q e <+> semi) es)) $$ + rbrace +ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> text (show 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 + TTyped t -> Typed y t + TRaw -> y + 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) = text (show 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 (EData) = text "data" +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 '>' -ppEquation (ps,e) = hcat (map (ppPatt 2) ps) <+> text "->" <+> ppTerm 0 e +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 -ppCase (p,e) = ppPatt 0 p <+> text "=>" <+> ppTerm 0 e +ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e -ppPatt d (PAlt p1 p2) = prec d 0 (ppPatt 0 p1 <+> char '|' <+> ppPatt 1 p2) -ppPatt d (PSeq p1 p2) = prec d 0 (ppPatt 0 p1 <+> char '+' <+> ppPatt 1 p2) -ppPatt d (PC f ps) = prec d 1 (ppIdent f <+> hsep (map (ppPatt 2) ps)) -ppPatt d (PP f g ps) = prec d 1 (ppIdent f <> char '.' <> ppIdent g <+> hsep (map (ppPatt 2) ps)) -ppPatt d (PRep p) = prec d 1 (ppPatt 2 p <> char '*') -ppPatt d (PAs f p) = prec d 1 (ppIdent f <> char '@' <> ppPatt 2 p) -ppPatt d (PNeg p) = prec d 1 (char '-' <> ppPatt 2 p) -ppPatt d (PChar) = char '?' -ppPatt d (PChars s) = brackets (text (show s)) -ppPatt d (PMacro id) = char '#' <> ppIdent id -ppPatt d (PM m id) = char '#' <> ppIdent m <> char '.' <> ppIdent id -ppPatt d (PV id) = ppIdent id -ppPatt d (PInt n) = integer n -ppPatt d (PFloat f) = double f -ppPatt d (PString s) = text (show s) -ppPatt d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt 0 e | (l,e) <- xs])) +ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> ppTerm q 0 e -ppDecl (id,typ) - | id == identW = ppTerm 4 typ - | otherwise = parens (ppIdent id <+> colon <+> ppTerm 0 typ) +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) = prec d 1 (ppIdent f <+> hsep (map (ppPatt q 2) ps)) +ppPatt q d (PP f g ps) = 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 (text (show s)) +ppPatt q d (PMacro id) = char '#' <> ppIdent id +ppPatt q d (PM m id) = char '#' <> ppIdent m <> char '.' <> ppIdent id +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) = text (show s) +ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs])) -ppDDecl (id,typ) - | id == identW = ppTerm 6 typ - | otherwise = parens (ppIdent id <+> colon <+> ppTerm 0 typ) +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 . prIdent +ppQIdent q m id = + case q of + Qualified -> ppIdent m <> char '.' <> ppIdent id + Unqualified -> ppIdent id + ppLabel = ppIdent . label2ident ppOpenSpec (OSimple id) = ppIdent id @@ -220,14 +245,14 @@ ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n) ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n) -ppLocDef (id, (mbt, e)) = +ppLocDef q (id, (mbt, e)) = ppIdent id <+> - (case mbt of {Just t -> colon <+> ppTerm 0 t; Nothing -> empty} <+> equals <+> ppTerm 0 e) <+> semi + (case mbt of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} <+> equals <+> ppTerm q 0 e) <+> semi -ppAltern (x,y) = ppTerm 0 x <+> char '/' <+> ppTerm 0 y +ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y -ppParam (id,cxt) = ppIdent id <+> hsep (map ppDDecl cxt) +ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt) commaPunct f ds = (hcat (punctuate comma (map f ds))) diff --git a/src/GFI.hs b/src/GFI.hs index e5926f5e9..486b807d0 100644 --- a/src/GFI.hs +++ b/src/GFI.hs @@ -95,12 +95,17 @@ loop opts gfenv0 = do system $ unwords ws loopNewCPU gfenv "cc":ws -> do - let - (style,term) = case ws of - ('-':w):ws2 -> (pTermPrintStyle w, ws2) - _ -> (TermPrintDefault, ws) - case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of - Ok x -> putStrLn $ enc (showTerm style x) + let + pOpts style q ("-table" :ws) = pOpts TermPrintTable q ws + pOpts style q ("-all" :ws) = pOpts TermPrintAll q ws + pOpts style q ("-default":ws) = pOpts TermPrintDefault q ws + pOpts style q ("-unqual" :ws) = pOpts style Unqualified ws + pOpts style q ("-qual" :ws) = pOpts style Qualified ws + pOpts style q ws = (style,q,unwords ws) + + (style,q,s) = pOpts TermPrintDefault Qualified ws + case pTerm s >>= checkTerm sgr >>= computeTerm sgr of + Ok x -> putStrLn $ enc (showTerm style q x) Bad s -> putStrLn $ enc s loopNewCPU gfenv "dg":ws -> do