@@ -0,0 +1,234 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+-- | In most cases import "Ormolu.Printer.Combinators" instead, these
5+-- functions are the low-level building blocks and should not be used on
6+-- their own. The 'R' monad is re-exported from "Ormolu.Printer.Combinators"
7+-- as well.
8+
9+module Ormolu.Printer.Internal
10+ ( -- * The 'R' monad
11+ R
12+ , runR
13+ -- * Internal functions
14+ , spit
15+ , newline
16+ , ensureIndent
17+ , inci
18+ , sitcc
19+ , Layout (..)
20+ , enterLayout
21+ , vlayout
22+ , lookupAnn
23+ )
24+where
25+
26+import Control.Monad.Reader
27+import Control.Monad.State.Strict
28+import Data.Data (Data)
29+import Data.Text (Text)
30+import Data.Text.Lazy.Builder
31+import Debug.Trace
32+import Language.Haskell.GHC.ExactPrint.Types
33+import SrcLoc
34+import qualified Data.Text.Lazy as TL
35+import qualified Data.Map as M
36+import qualified Data.Text as T
37+
38+----------------------------------------------------------------------------
39+-- The 'R' monad
40+
41+-- | The 'R' monad hosts combinators that allow us to describe how to render
42+-- AST.
43+
44+newtype R a = R (ReaderT RC (State SC) a)
45+ deriving (Functor, Applicative, Monad)
46+
47+-- | Reader context of 'R'.
48+
49+data RC = RC
50+ { rcIndent :: !Int
51+ -- ^ Indentation level, as the column index we need to start from after a
52+ -- newline if we break lines
53+ , rcLayout :: Layout
54+ -- ^ Current layout
55+ , rcAnns :: Anns
56+ -- ^ The collection of annotations obtained after parsing
57+ , rcDebug :: Bool
58+ -- ^ Whether to print debugging info as we go
59+ }
60+
61+-- | State context of 'R'.
62+
63+data SC = SC
64+ { scColumn :: !Int
65+ -- ^ Index of the next column to render
66+ , scBuilder :: Builder
67+ -- ^ Rendered source code so far
68+ }
69+
70+-- | 'Layout' options.
71+
72+data Layout
73+ = SingleLine -- ^ Put everything on single line
74+ | MultiLine -- ^ Use multiple lines
75+ deriving (Eq, Show)
76+
77+-- | Run an 'R' monad.
78+
79+runR
80+ :: Bool -- ^ Whether to print debugging info
81+ -> R () -- ^ Monad to run
82+ -> Anns -- ^ Annotations to use
83+ -> Text -- ^ Resulting rendition
84+runR debug (R m) anns =
85+ TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc
86+ where
87+ rc = RC
88+ { rcIndent = 0
89+ , rcLayout = MultiLine
90+ , rcAnns = anns
91+ , rcDebug = debug
92+ }
93+ sc = SC
94+ { scColumn = 0
95+ , scBuilder = mempty
96+ }
97+
98+----------------------------------------------------------------------------
99+-- Internal functions
100+
101+-- | Grow current output by appending given 'Text' to it, which may not
102+-- contain newlines.
103+
104+spit :: Text -> R ()
105+spit x = do
106+ traceR "spit_before" (Just x)
107+ R (modify modSC)
108+ traceR "spit_after" Nothing
109+ where
110+ modSC sc = sc
111+ { scBuilder = scBuilder sc <> fromText x
112+ , scColumn = scColumn sc + T.length x
113+ }
114+
115+-- | Output a newline.
116+
117+newline :: R ()
118+newline = do
119+ traceR "newline_before" (Just "\n")
120+ R (modify modSC)
121+ traceR "newline_after" Nothing
122+ where
123+ modSC sc = sc
124+ { scBuilder = scBuilder sc <> "\n"
125+ , scColumn = 0
126+ }
127+
128+-- | Ensure that indentation level is satisfied. Insert correct number of
129+-- spaces if it isn't.
130+
131+ensureIndent :: R ()
132+ensureIndent = do
133+ traceR "ensure_indent" Nothing
134+ i <- R (asks rcIndent)
135+ c <- R (gets scColumn)
136+ when (c < i) $
137+ spit (T.replicate (i - c) " ")
138+
139+-- | Increase indentation level by one indentation step for the inner
140+-- computation.
141+
142+inci :: R () -> R ()
143+inci m' = do
144+ traceR "inci_before" Nothing
145+ let R m = traceR "inci_inside" Nothing >> m'
146+ R (local modRC m)
147+ traceR "inci_ended" Nothing
148+ where
149+ modRC x = x
150+ { rcIndent = rcIndent x + indentStep
151+ }
152+
153+-- | Set indentation level for the inner computation equal to current
154+-- column. This makes sure that the entire inner block is uniformly
155+-- \"shifted\" to the right. Only works (and makes sense) when enclosing
156+-- layout is multilined.
157+
158+sitcc :: R () -> R ()
159+sitcc m' = do
160+ traceR "sitcc_before" Nothing
161+ i <- R (asks rcIndent)
162+ c <- R (gets scColumn)
163+ let modRC x = x
164+ { rcIndent = max i c
165+ }
166+ R m = traceR "sitcc_inside" Nothing >> m'
167+ vlayout m' (R (local modRC m))
168+ traceR "sitcc_ended" Nothing
169+
170+-- | Set 'Layout' for internal computation.
171+
172+enterLayout :: Layout -> R () -> R ()
173+enterLayout l (R m) = do
174+ let label =
175+ case l of
176+ SingleLine -> "single_line"
177+ MultiLine -> "multi_line"
178+ traceR ("lstart_" ++ label) Nothing
179+ let modRC x = x
180+ { rcLayout = l
181+ }
182+ R (local modRC m)
183+ traceR ("lend_" ++ label) Nothing
184+
185+-- | Do one or another thing depending on current 'Layout'.
186+
187+vlayout
188+ :: R () -- ^ Single line
189+ -> R () -- ^ Multi line
190+ -> R ()
191+vlayout sline mline = do
192+ l <- R (asks rcLayout)
193+ case l of
194+ SingleLine -> sline
195+ MultiLine -> mline
196+
197+-- | Lookup an annotation.
198+
199+lookupAnn :: Data a => Located a -> R (Maybe Annotation)
200+lookupAnn (L s d) = do
201+ anns <- R (asks rcAnns)
202+ let k = AnnKey s (annGetConstr d)
203+ traceShow k $ return (M.lookup k anns)
204+
205+----------------------------------------------------------------------------
206+-- Debug helpers
207+
208+-- | Tracing helper.
209+
210+traceR
211+ :: String -- ^ Label
212+ -> Maybe Text -- ^ Output, if any
213+ -> R ()
214+traceR label moutput = R $ do
215+ debug <- asks rcDebug
216+ i <- asks rcIndent
217+ c <- gets scColumn
218+ when debug . traceM . concat $
219+ [ replicate i ' '
220+ , unwords [ label ++ ":"
221+ , "i=" ++ show i
222+ , "c=" ++ show c
223+ ]
224+ ] ++ case moutput of
225+ Nothing -> []
226+ Just output -> [" out=" ++ show output]
227+
228+----------------------------------------------------------------------------
229+-- Constants
230+
231+-- | Indentation step.
232+
233+indentStep :: Int
234+indentStep = 2