1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164

module Curry.ExactPrintClass
 ( ExactPrint(keywords, printS, printN), PrintAt(..), PutExact, Exact
 , exactPrint, printNode, empty, fill, noChilds, printStringAt, printListAt
 ) where

import List

import Curry.Types
import Curry.Comment
import Curry.Position
import Curry.Span
import Curry.SpanInfo

-- ShowS for efficiency.
type EPS = [(Span, String)] -> Position -> (ShowS, [(Span, String)], Position)

-- Monadic EPS
newtype EPSM a = EPSM (a, EPS)

type PutExact = EPSM ()

newtype Exact = Exact {
    unExact :: PutExact
  }

instance Functor EPSM where
  fmap f (EPSM (a, x)) = EPSM (f a, x)

instance Monad EPSM where
  return a = EPSM (a, emptyEPS)
  EPSM (a, eps1) >>= f = let EPSM (b, eps2) = f a in EPSM (b, eps1 <+> eps2)
  EPSM (_, eps1) >> EPSM (b, eps2) = EPSM (b, eps1 <+> eps2)

exactPrint :: ExactPrint a => a -> [(Span, Comment)] -> String
exactPrint = exactPrintFrom 1

exactPrintFrom :: ExactPrint a => Int -> a -> [(Span, Comment)] -> String
exactPrintFrom l a cs =
  let EPSM (_, f) = printNode a in fst3 (f cs' (Position l 1)) ""
  where cs' = map (\(sp,c) -> (sp, commentString c)) cs -- comments are just kws
        fst3 (x,_,_) = x

class PrintAt a where
  printString :: a -> String
  printSpan   :: a -> Span

class HasSpanInfo a => ExactPrint a where
  keywords :: a -> [String]
  printS   :: a -> Exact

  -- Adds keywords to the whitespace-replacement of a EPS computation
  -- and fills Whitespace up to the beginning
  printN :: a -> PutExact
  printN a = liftEPS $ withSrcInfoPoints (getSpanInfo a) (keywords a) eps
    where
      EPSM (_, eps) = do
        liftEPS $ fillUpS (getStartPosition a) -- fill space before entity
        unExact $ printS  a                    -- collect keywords to print
        liftEPS $ fillUpS (getEndPosition   a) -- print them, add trailing space

instance ExactPrint a => ExactPrint [a] where
  printS      = Exact . sequenceExact
  keywords _  = []
  printN   xs = sequenceExact xs

printStringAt :: Span -> String -> PutExact
printStringAt sp s =
  liftEPS $ withSrcInfoPoints (SpanInfo sp [sp]) [s] eps
  where
    EPSM (_, eps) = do
      liftEPS $ fillUpS (start sp) -- fill space before string
      empty                        -- no other keywords to print
      liftEPS $ fillUpS (end   sp) -- print string, add trailing space

printListAt :: PrintAt a => [a] -> PutExact
printListAt []     = empty
printListAt (x:xs) =
  printStringAt (printSpan x) (printString x) >> printListAt xs

printNode :: ExactPrint a => a -> PutExact
printNode = printN

empty :: PutExact
empty = liftEPS emptyEPS

fill :: PutExact -> Exact
fill = Exact

noChilds :: Exact
noChilds = Exact empty

-------------------------------------------------------------------------
-- Internals
-------------------------------------------------------------------------

liftEPS :: EPS -> PutExact
liftEPS e = EPSM ((), e)

--------------------
-- Combinators
--------------------

(<+>) :: EPS -> EPS -> EPS
eps1 <+> eps2 = \cs1 p1 -> let (s2,      cs2, p2) = eps1 cs1 p1
                               (s3,      cs3, p3) = eps2 cs2 p2
                           in  (s2 . s3, cs3, p3)

replicateS :: Int -> Char -> ShowS
replicateS n c | n <  0    = error "negative value"
               | n == 0    = id
               | otherwise = showChar c . replicateS (n-1) c

emptyEPS :: EPS
emptyEPS cs p = (id, cs, p)

sequenceExact :: ExactPrint a => [a] -> PutExact
sequenceExact = sequence_ . map printNode

--------------------------------------------
-- implementation details for exactPrintFull
--------------------------------------------

-- open a new scope for the new computation and add the new keywords
-- to the list of (filtered) keywords just for this scope.
-- Use the rest when exiting this scope
withSrcInfoPoints :: SpanInfo -> [String] -> EPS -> EPS
withSrcInfoPoints NoSpanInfo        _        _   _  _ = error "NoSpanInfo"
withSrcInfoPoints (SpanInfo sp sps) keyws eps cs p =
  replaceComments $ eps (merge (zip sps keyws) bef) p
  where (aft, bef) = partition ((`isAfter` sp) . fst) cs
        replaceComments (s, _, p') = (s, aft, p')

merge :: [(Span, a)] -> [(Span, a)] -> [(Span, a)]
merge []          []       = []
merge xs@(_:_)    []       = xs
merge []          ys@(_:_) = ys
merge ((sx,x):xs) ((sy,y):ys)
        | sx `isBefore` sy = (sx, x) : merge xs ((sy,y):ys)
        | otherwise        = (sy, y) : merge ((sx,x):xs) ys

fillUpS :: Position -> EPS
fillUpS fillEnd []          p = case (p, fillEnd) of
    (Position l1 c1, Position l2 c2)
      | l1 <  l2  -> whitespaceUntil (l2 - l1) (c2 - 1) [] fillEnd
      | l1 == l2 &&
        c1 <= c2  -> whitespaceUntil 0 (c2 - c1) [] fillEnd
      | otherwise -> (id, [], p)
    _             -> error "No Positional information available"
fillUpS fillEnd ((sp,c):cs) p = case (sp, fillEnd) of
    (Span (Position l1 c1) _, Position l2 c2)
      | l1 <  l2 ||
       (l1 == l2 &&
        c1 <= c2) -> (exactPrintOther (sp, c) <+> fillUpS fillEnd) cs p
      | otherwise -> replaceComments $ fillUpS fillEnd [] p
    _             -> error "No Positional information available"
  where replaceComments (s, _, p') = (s, (sp,c):cs, p')

exactPrintOther :: (Span, String) -> EPS
exactPrintOther (sp, s) cs p =
  let (s', _, _) = fillUpS (start sp) [] p
  in (s' . showString s, cs, incr (end sp) 1)

whitespaceUntil :: Int -> Int -> EPS
whitespaceUntil l c cs p = (replicateS l '\n' . replicateS c ' ', cs, p)