4c76d56 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Respect precedence and associativity for infix ops in pprint

4c76d56David Raymond Christiansen12 years ago

src/Idris/AbsSyntaxTree.hs+27−2

compare with master

unifiedsplit

@@ -31,6 +31,7 @@ import qualified Data.Map as M

31import Data.Either

32import qualified Data.Set as S

33import Data.Word (Word)

34+import Data.Maybe (fromMaybe)

35import Debug.Trace

36import Debug.Trace

@@ -1133,6 +1134,10 @@ prettyImp :: Bool -- ^^ whether to show implicits

1133 -> Doc OutputAnnotation

1134 -> Doc OutputAnnotation

1134prettyImp impl = pprintPTerm impl [] [] []

1135prettyImp impl = pprintPTerm impl [] [] []

1135

1136

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+

1136-- | Pretty-print a high-level Idris term in some bindings context with infix info

1141-- | Pretty-print a high-level Idris term in some bindings context with infix info

1137pprintPTerm :: Bool -- ^^ whether to show implicits

1142pprintPTerm :: Bool -- ^^ whether to show implicits

1138 -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit

1143 -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit

@@ -1205,13 +1210,23 @@ pprintPTerm impl bnd docArgs infixes = prettySe 10 bnd

1205 case getExps args of

1210 case getExps args of

1206 [] -> enclose lparen rparen opName

1211 [] -> enclose lparen rparen opName

1207 [x] -> group (enclose lparen rparen opName <$> group (prettySe 0 bnd x))

1212 [x] -> group (enclose lparen rparen opName <$> group (prettySe 0 bnd x))

1213+ [l,r] -> let precedence = fromMaybe 20 (fmap prec f)

1208− [l,r] -> bracket p 1 $ inFix l r

1214+ in trace ("p=" ++ show p++",prec="++show precedence) (bracket p precedence $ inFix l r)

1209 (l:r:rest) -> bracket p 1 $

1215 (l:r:rest) -> bracket p 1 $

1210 enclose lparen rparen (inFix l r) <+>

1216 enclose lparen rparen (inFix l r) <+>

1211 align (group (vsep (map (prettyArgSe bnd) rest)))

1217 align (group (vsep (map (prettyArgSe bnd) rest)))

1212 where opName = prettyName impl bnd op

1218 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

1213 inFix l r = align . group $

1228 inFix l r = align . group $

1214− (prettySe 1 bnd l <+> opName) <$> group (prettySe 0 bnd r)

1229+ (left l <+> opName) <$> group (right r)

1215 prettySe p bnd (PApp _ hd@(PRef fc f) [tm])

1230 prettySe p bnd (PApp _ hd@(PRef fc f) [tm])

1216 | PConstant (Idris.Core.TT.Str str) <- getTm tm,

1231 | PConstant (Idris.Core.TT.Str str) <- getTm tm,

1217 f == sUN "Symbol_" = char '\'' <> prettySe 10 bnd (PRef fc (sUN str))

1232 f == sUN "Symbol_" = char '\'' <> prettySe 10 bnd (PRef fc (sUN str))

@@ -1316,6 +1331,10 @@ pprintPTerm impl bnd docArgs infixes = prettySe 10 bnd

1316 annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation

1331 annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation

1317 annName n = annotate (AnnName n Nothing Nothing Nothing)

1332 annName n = annotate (AnnName n Nothing Nothing Nothing)

1318

1333

1334+ opStr :: Name -> String

1335+ opStr (NS n _) = opStr n

1336+ opStr (UN n) = T.unpack n

1337+

1319 basename :: Name -> Name

1338 basename :: Name -> Name

1320 basename (NS n _) = basename n

1339 basename (NS n _) = basename n

1321 basename n = n

1340 basename n = n

@@ -1369,6 +1388,12 @@ pprintPTerm impl bnd docArgs infixes = prettySe 10 bnd

1369

1388

1370 kwd = annotate AnnKeyword . text

1389 kwd = annotate AnnKeyword . text

1371

1390

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+

1372-- | Pretty-printer helper for the binding site of a name

1397-- | Pretty-printer helper for the binding site of a name

1373bindingOf :: Name -- ^^ the bound name

1398bindingOf :: Name -- ^^ the bound name

1374 -> Bool -- ^^ whether the name is implicit

1399 -> Bool -- ^^ whether the name is implicit

src/Idris/REPL.hs+10−13

@@ -563,21 +563,19 @@ process h fn (Eval t)

563 ist <- getIState

564 logLvl 3 $ "Raw: " ++ show (tm', ty')

565 logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'

566− let imp = opt_showimp (idris_options ist)

567− tmDoc = prettyImp imp (delab ist tm')

566+ let tmDoc = prettyIst ist (delab ist tm')

568− tyDoc = prettyImp imp (delab ist ty')

567+ tyDoc = prettyIst ist (delab ist ty')

569 ihPrintTermWithType h tmDoc tyDoc

568 ihPrintTermWithType h tmDoc tyDoc

570

569

571process h fn (ExecVal t)

570process h fn (ExecVal t)

572 = do ctxt <- getContext

571 = do ctxt <- getContext

573 ist <- getIState

572 ist <- getIState

574− let imp = opt_showimp (idris_options ist)

575 (tm, ty) <- elabVal toplevel False t

573 (tm, ty) <- elabVal toplevel False t

576-- let tm' = normaliseAll ctxt [] tm

574-- let tm' = normaliseAll ctxt [] tm

577 let ty' = normaliseAll ctxt [] ty

575 let ty' = normaliseAll ctxt [] ty

578 res <- execute tm

576 res <- execute tm

579− let (resOut, tyOut) = (prettyImp imp (delab ist res),

577+ let (resOut, tyOut) = (prettyIst ist (delab ist res),

580− prettyImp imp (delab ist ty'))

578+ prettyIst ist (delab ist ty'))

581 ihPrintTermWithType h resOut tyOut

579 ihPrintTermWithType h resOut tyOut

582

580

583process h fn (Check (PRef _ n))

581process h fn (Check (PRef _ n))

@@ -623,9 +621,9 @@ process h fn (Check t)

623 ty' = normaliseC ctxt [] ty

621 ty' = normaliseC ctxt [] ty

624 case tm of

622 case tm of

625 TType _ ->

623 TType _ ->

626− ihPrintTermWithType h (prettyImp imp PType) type1Doc

624+ ihPrintTermWithType h (prettyIst ist PType) type1Doc

627− _ -> ihPrintTermWithType h (prettyImp imp (delab ist tm))

625+ _ -> ihPrintTermWithType h (prettyIst ist (delab ist tm))

628− (prettyImp imp (delab ist ty))

626+ (prettyIst ist (delab ist ty))

629

627

630process h fn (DocStr n)

628process h fn (DocStr n)

631 = do ist <- getIState

629 = do ist <- getIState

@@ -1051,15 +1049,14 @@ process h fn (SetConsoleWidth w) = setWidth w

1051

1049

1052process h fn (Apropos a) =

1050process h fn (Apropos a) =

1053 do ist <- getIState

1051 do ist <- getIState

1054− let impl = opt_showimp (idris_options ist)

1055 let names = apropos ist (T.pack a)

1052 let names = apropos ist (T.pack a)

1056 let aproposInfo = [ (n,

1053 let aproposInfo = [ (n,

1057 delabTy ist n,

1054 delabTy ist n,

1058 fmap (overview . fst) (lookupCtxtExact n (idris_docstrings ist)))

1055 fmap (overview . fst) (lookupCtxtExact n (idris_docstrings ist)))

1059 | n <- sort names, isUN n ]

1056 | n <- sort names, isUN n ]

1060− ihRenderResult h $ vsep (map (renderApropos impl) aproposInfo)

1057+ ihRenderResult h $ vsep (map (renderApropos ist) aproposInfo)

1061− where renderApropos impl (name, ty, docs) =

1058+ where renderApropos ist (name, ty, docs) =

1062− prettyName True [] name <+> colon <+> align (prettyImp impl ty) <$>

1059+ prettyName True [] name <+> colon <+> align (prettyIst ist ty) <$>

1063 fromMaybe empty (fmap (\d -> renderDocstring d <> line) docs)

1060 fromMaybe empty (fmap (\d -> renderDocstring d <> line) docs)

1064 isUN (UN _) = True

1061 isUN (UN _) = True

1065 isUN (NS n _) = isUN n

1062 isUN (NS n _) = isUN n