@@ -31,6 +31,7 @@ import Util.System (isATTY)
3131
3232import Prelude hiding ((<$>))
3333
34+import Control.Arrow (first)
3435import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT)
3536import Data.List (intersperse, nub)
3637import Data.Maybe (fromMaybe, fromJust, isJust, listToMaybe)
@@ -52,13 +53,15 @@ pshow ist err = displayDecorated (consoleDecorate ist) .
5253
5354type OutputDoc = Doc OutputAnnotation
5455
56+data Ann = AText String | ATagged OutputAnnotation Ann | ASplit Ann Ann
57+
5558iWarn :: FC -> OutputDoc -> Idris ()
5659iWarn fc err =
5760 do i <- getIState
5861 case idris_outputmode i of
5962 RawOutput h ->
6063 do maybeSource <- readSource fc
61− let maybeFormattedSource = (maybeSource >>= layoutSource fc)
64+ let maybeFormattedSource = (maybeSource >>= layoutSource fc (idris_highlightedRegions i))
6265 err' <- iRender . fmap (fancifyAnnots i True) $
6366 layoutWarning (layoutFC fc) maybeFormattedSource err
6467 hWriteDoc h i err'
@@ -80,8 +83,8 @@ iWarn fc err =
8083 Right v -> pure (Just v)
8184 readSource _ = pure Nothing
8285
83− layoutSource :: FC -> String -> Maybe OutputDoc
84− layoutSource (FC fn (si, sj) (ei, ej)) src =
86+ layoutSource :: FC -> [(FC, OutputAnnotation)] -> String -> Maybe OutputDoc
87+ layoutSource (FC fn (si, sj) (ei, ej)) highlights src =
8588 if haveSource
8689 then Just source
8790 else Nothing
@@ -95,8 +98,51 @@ iWarn fc err =
9598 line1 :: OutputDoc
9699 line1 = text $ replicate (length (show si)) ' ' ++ " |"
97100
101+ lineFC :: FC
102+ lineFC = FC fn (si, 1) (si, length (fromJust sourceLine))
103+
104+ intersection :: FC -> FC -> FC
105+ intersection (FC fn1 s1 e1) (FC fn2 s2 e2) = FC fn1 (max s1 s2) (min e1 e2)
106+ intersection _ _ = NoFC
107+
108+ intersects :: FC -> FC -> Bool
109+ intersects (FC fn1 s1 e1) (FC fn2 s2 e2)
110+ | fn1 /= fn2 = False
111+ | e1 < s2 = False
112+ | e2 < s1 = False
113+ | otherwise = True
114+ intersects _ _ = False
115+
116+ width :: Ann -> Int
117+ width (AText s) = length s
118+ width (ATagged _ n) = width n
119+ width (ASplit l r) = width l + width r
120+
121+ buildHighlightedSource :: Ann -> OutputDoc
122+ buildHighlightedSource (AText s) = text s
123+ buildHighlightedSource (ATagged a n) = annotate a (buildHighlightedSource n)
124+ buildHighlightedSource (ASplit l r) = buildHighlightedSource l <> buildHighlightedSource r
125+
126+ insertAnnotation :: ((Int, Int), OutputAnnotation) -> Ann -> Ann
127+ insertAnnotation ((sj, ej), oa) (ATagged tag n) = ATagged tag (insertAnnotation ((sj, ej), oa) n)
128+ insertAnnotation ((sj, ej), oa) (ASplit l r)
129+ | w <- width l = ASplit (insertAnnotation ((sj, ej), oa) l) (insertAnnotation ((sj - w, ej - w), oa) r)
130+ insertAnnotation ((sj, ej), oa) a@(AText t)
131+ | sj <= 1, ej >= width a = ATagged oa a
132+ | sj > 1, sj <= width a = ASplit (AText $ take (sj - 1) t) (insertAnnotation ((1, ej - sj + 1), oa) (AText $ drop (sj - 1) t))
133+ | sj == 1, ej >= 1, ej < width a = ASplit (insertAnnotation ((1, ej), oa) (AText $ take ej t)) (AText $ drop ej t)
134+ | otherwise = a
135+
136+ highlightedSource :: OutputDoc
137+ highlightedSource = buildHighlightedSource .
138+ foldr insertAnnotation (AText $ fromJust sourceLine) .
139+ map (\(FC _ (_, sj) (_, ej), ann) -> ((sj, ej), ann)) .
140+ map (first (intersection lineFC)) .
141+ filter (intersects lineFC . fst) $
142+ highlights
143+
98144 line2 :: OutputDoc
99− line2 = text $ show si ++ " | " ++ fromJust sourceLine
145+ line2 = text (show si ++ " | ") <> highlightedSource
100146
101147 indicator :: OutputDoc
102148 indicator = text (replicate (end - sj + 1) ch) <> ellipsis
@@ -111,7 +157,7 @@ iWarn fc err =
111157
112158 source :: OutputDoc
113159 source = line1 <$$> line2 <$$> line3
114− layoutSource _ _ = Nothing
160+ layoutSource _ _ _ = Nothing
115161
116162 layoutWarning :: OutputDoc -> Maybe OutputDoc -> OutputDoc -> OutputDoc
117163 layoutWarning loc (Just src) err = loc <$$> src <$$> err <$$> empty