git.iko.soy/Idris-dev
on master help sign in
Respect precedence and associativity for infix ops in pprint

Fixes #1050.

commit4c76d56e18adbcd7686af4790c9b4f95fefcbdc5 authorDavid Raymond Christiansen <david@davidchristiansen.dk> dateFri 2 May 2014, 12:07 (12 years ago) parentbfe6499
2 files changed+37−15
compare with master
unifiedsplit
src/Idris/AbsSyntaxTree.hs+27−2 src/Idris/REPL.hs+10−13
src/Idris/AbsSyntaxTree.hs+27−2
@@ -31,6 +31,7 @@ import qualified Data.Map as M
3131import Data.Either
3232import qualified Data.Set as S
3333import Data.Word (Word)
34+import Data.Maybe (fromMaybe)
3435
3536import Debug.Trace
3637
@@ -1133,6 +1134,10 @@ prettyImp :: Bool -- ^^ whether to show implicits
11331134 -> Doc OutputAnnotation
11341135prettyImp impl = pprintPTerm impl [] [] []
11351136
1137+-- | Do the right thing for rendering a term in an IState
1138+prettyIst :: IState -> PTerm -> Doc OutputAnnotation
1139+prettyIst ist = pprintPTerm (opt_showimp (idris_options ist)) [] [] (idris_infixes ist)
1140+
11361141-- | Pretty-print a high-level Idris term in some bindings context with infix info
11371142pprintPTerm :: Bool -- ^^ whether to show implicits
11381143 -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit
@@ -1205,13 +1210,23 @@ pprintPTerm impl bnd docArgs infixes = prettySe 10 bnd
12051210 case getExps args of
12061211 [] -> enclose lparen rparen opName
12071212 [x] -> group (enclose lparen rparen opName <$> group (prettySe 0 bnd x))
1208− [l,r] -> bracket p 1 $ inFix l r
1213+ [l,r] -> let precedence = fromMaybe 20 (fmap prec f)
1214+ in trace ("p=" ++ show p++",prec="++show precedence) (bracket p precedence $ inFix l r)
12091215 (l:r:rest) -> bracket p 1 $
12101216 enclose lparen rparen (inFix l r) <+>
12111217 align (group (vsep (map (prettyArgSe bnd) rest)))
12121218 where opName = prettyName impl bnd op
1219+ f = getFixity (opStr op)
1220+ left l = case f of
1221+ Nothing -> prettySe (-1) bnd l
1222+ Just (Infixl p') -> prettySe p' bnd l
1223+ Just f' -> prettySe (prec f'-1) bnd l
1224+ right r = case f of
1225+ Nothing -> prettySe (-1) bnd r
1226+ Just (Infixr p') -> prettySe p' bnd r
1227+ Just f' -> prettySe (prec f'-1) bnd r
12131228 inFix l r = align . group $
1214− (prettySe 1 bnd l <+> opName) <$> group (prettySe 0 bnd r)
1229+ (left l <+> opName) <$> group (right r)
12151230 prettySe p bnd (PApp _ hd@(PRef fc f) [tm])
12161231 | PConstant (Idris.Core.TT.Str str) <- getTm tm,
12171232 f == sUN "Symbol_" = char '\'' <> prettySe 10 bnd (PRef fc (sUN str))
@@ -1316,6 +1331,10 @@ pprintPTerm impl bnd docArgs infixes = prettySe 10 bnd
13161331 annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation
13171332 annName n = annotate (AnnName n Nothing Nothing Nothing)
13181333
1334+ opStr :: Name -> String
1335+ opStr (NS n _) = opStr n
1336+ opStr (UN n) = T.unpack n
1337+
13191338 basename :: Name -> Name
13201339 basename (NS n _) = basename n
13211340 basename n = n
@@ -1369,6 +1388,12 @@ pprintPTerm impl bnd docArgs infixes = prettySe 10 bnd
13691388
13701389 kwd = annotate AnnKeyword . text
13711390
1391+ fixities :: M.Map String Fixity
1392+ fixities = M.fromList [(s, f) | (Fix f s) <- infixes]
1393+
1394+ getFixity :: String -> Maybe Fixity
1395+ getFixity = flip M.lookup fixities
1396+
13721397-- | Pretty-printer helper for the binding site of a name
13731398bindingOf :: Name -- ^^ the bound name
13741399 -> Bool -- ^^ whether the name is implicit
src/Idris/REPL.hs+10−13
@@ -563,21 +563,19 @@ process h fn (Eval t)
563563 ist <- getIState
564564 logLvl 3 $ "Raw: " ++ show (tm', ty')
565565 logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'
566− let imp = opt_showimp (idris_options ist)
567− tmDoc = prettyImp imp (delab ist tm')
568− tyDoc = prettyImp imp (delab ist ty')
566+ let tmDoc = prettyIst ist (delab ist tm')
567+ tyDoc = prettyIst ist (delab ist ty')
569568 ihPrintTermWithType h tmDoc tyDoc
570569
571570process h fn (ExecVal t)
572571 = do ctxt <- getContext
573572 ist <- getIState
574− let imp = opt_showimp (idris_options ist)
575573 (tm, ty) <- elabVal toplevel False t
576574-- let tm' = normaliseAll ctxt [] tm
577575 let ty' = normaliseAll ctxt [] ty
578576 res <- execute tm
579− let (resOut, tyOut) = (prettyImp imp (delab ist res),
580− prettyImp imp (delab ist ty'))
577+ let (resOut, tyOut) = (prettyIst ist (delab ist res),
578+ prettyIst ist (delab ist ty'))
581579 ihPrintTermWithType h resOut tyOut
582580
583581process h fn (Check (PRef _ n))
@@ -623,9 +621,9 @@ process h fn (Check t)
623621 ty' = normaliseC ctxt [] ty
624622 case tm of
625623 TType _ ->
626− ihPrintTermWithType h (prettyImp imp PType) type1Doc
627− _ -> ihPrintTermWithType h (prettyImp imp (delab ist tm))
628− (prettyImp imp (delab ist ty))
624+ ihPrintTermWithType h (prettyIst ist PType) type1Doc
625+ _ -> ihPrintTermWithType h (prettyIst ist (delab ist tm))
626+ (prettyIst ist (delab ist ty))
629627
630628process h fn (DocStr n)
631629 = do ist <- getIState
@@ -1051,15 +1049,14 @@ process h fn (SetConsoleWidth w) = setWidth w
10511049
10521050process h fn (Apropos a) =
10531051 do ist <- getIState
1054− let impl = opt_showimp (idris_options ist)
10551052 let names = apropos ist (T.pack a)
10561053 let aproposInfo = [ (n,
10571054 delabTy ist n,
10581055 fmap (overview . fst) (lookupCtxtExact n (idris_docstrings ist)))
10591056 | n <- sort names, isUN n ]
1060− ihRenderResult h $ vsep (map (renderApropos impl) aproposInfo)
1061− where renderApropos impl (name, ty, docs) =
1062− prettyName True [] name <+> colon <+> align (prettyImp impl ty) <$>
1057+ ihRenderResult h $ vsep (map (renderApropos ist) aproposInfo)
1058+ where renderApropos ist (name, ty, docs) =
1059+ prettyName True [] name <+> colon <+> align (prettyIst ist ty) <$>
10631060 fromMaybe empty (fmap (\d -> renderDocstring d <> line) docs)
10641061 isUN (UN _) = True
10651062 isUN (NS n _) = isUN n