" ++ (outputAnn (rextract t) False i showt) ++ (annotationMark i t (printIndMaster i t)) ++ "
"
where showt = prettyp (show (setCompactSrcLocs $ fmap (\x -> ()) t))
{-
instance PrintIndSlave (Decl p) HTMLPP where
outputPrintSlave i t = "" ++ (outputAnn (rextract t) False i showt) ++ (annotationMark i t (printIndMaster i t)) ++ "
"
where showt = prettyp (show (setCompactSrcLocs $ fmap (\x -> ()) t))x
-}
countToColor n = colors !! (n `mod` (length colors)) -- printf "#%06x" ((256*256*256 - (n * 40)) :: Int)
colors = ["#ffeeee", "#eeffee", "#eeeeff", "#ffffee",
"#eeffff", "#eeffee", "#ffdddd", "#ddffdd",
"#ddddff", "#ffffdd", "#ffddff", "#ddffff",
"#eecccc", "#cceecc", "#eeeecc", "#ddeeee"]
prettyp xs = prettyp' xs 0 []
prettyp' [] n f = []
prettyp' ('(':xs) n f = let k = "" ++
"
" ++ (show $ number t) ++ "
" ++
"
" ++
"show ast
" ++ (astString) ++ "
" ++ "
" ++
row ["lives: (in) ", showList $ (map show) $ fst $ lives t, "(out)", showList $ (map show) $ snd $ lives t] ++
row ["indices:", showList $ indices t] ++
row ["successors:", showList $ (map show) (successorStmts t)] ++
row ["arrays R:", showExps (assocs $ arrsRead t)] ++
row ["arrays W:", showExps (assocs $ arrsWrite t)] ++
"
\n\r\n"
where
listToPair x = "(" ++ listToPair' x ++ ")"
listToPair' [] = ""
listToPair' [x] = printMaster x
listToPair' (x:xs) = printMaster x ++ ", " ++ listToPair' xs
showExps [] = ""
showExps [(v, es)] = "[" ++ v ++ ": " ++ (showList $ map listToPair es) ++ "]"
showExps ((v, es):ys) = (showExps [(v, es)]) ++ ", " ++ (showExps ys)
showList [] = ""
showList [x] = x
showList (x:xs) = x ++ ", " ++ showList xs
type A1 = Bool
lineCol :: SrcLoc -> (Int, Int)
lineCol x = (srcLine x, srcColumn x)
-- inBounds :: SrcLoc -> (SrcLoc, SrcLoc) -> Bool
-- inBounds x (l,u) = (lineCol x) >= (lineCol l) && (lineCol x) < (lineCol u)
takeBounds (l, u) inp = takeBounds' (lineCol l, lineCol u) [] inp
takeBounds' ((ll, lc), (ul, uc)) tk inp =
if (ll == ul && lc == uc) || (ll > ul) then (Prelude.reverse tk, inp)
else case inp of [] -> (Prelude.reverse tk, inp)
([]:[]) -> (Prelude.reverse tk, inp)
([]:ys) -> takeBounds' ((ll+1, 0), (ul, uc)) ('\n':tk) ys
((x:xs):ys) -> takeBounds' ((ll, lc+1), (ul, uc)) (x:tk) (xs:ys)
{- Indenting for refactored code -}
instance Tagged p => Indentor (p Annotation) where
indR t i = case (refactored . tag $ t) of
Just (SrcLoc f _ c) -> Prelude.take c (repeat ' ')
Nothing -> ind i
-- Start of GLORIOUS REFACTORING ALGORITHM!
{-| -}
reprint :: SourceText -> Filename -> Program Annotation -> String
reprint "" f p = let ?variant = DefaultPP in foldl (\a b -> a ++ "\n" ++ printMaster b) "" p
reprint input f p = let input' = Prelude.lines input
start = SrcLoc f 1 0
end = SrcLoc f (Prelude.length input') (1 + (Prelude.length $ Prelude.last input'))
(pn, cursorn) = runIdentity $ evalStateT (reprintC start input' (toZipper p)) 0
(_, inpn) = takeBounds (start, cursorn) input'
(pe, _) = takeBounds (cursorn, end) inpn
in pn ++ pe
reprintC :: Monad m => SrcLoc -> [String] -> Zipper a -> StateT Int m (String, SrcLoc)
reprintC cursor inp z =
do (p1, cursor', flag) <- query (refactoring inp cursor) z
(_, inp') <- return $ takeBounds (cursor, cursor') inp
(p2, cursor'') <- if flag then return ("", cursor')
else enterDown cursor' inp' z
(_, inp'') <- return $ takeBounds (cursor', cursor'') inp'
(p3, cursor''') <- enterRight cursor'' inp'' z
return (p1 ++ p2 ++ p3, cursor''')
enterDown cursor inp z = case (down' z) of
Just dz -> reprintC cursor inp dz
Nothing -> return $ ("", cursor)
enterRight cursor inp z = case (right z) of
Just rz -> reprintC cursor inp rz
Nothing -> return $ ("", cursor)
-- End of GLORIOUS REFACTORING ALGORITHM
{- Specifies how to do specific refactorings
(uses generic query extension - remember extQ is non-symmetric)
-}
refactoring :: (Typeable a, Monad m) => [String] -> SrcLoc -> a -> StateT Int m (String, SrcLoc, Bool)
refactoring inp cursor = ((((\_ -> return ("", cursor, False))
`extQ` (refactorUses inp cursor))
`extQ` (refactorDecl inp cursor))
`extQ` (refactorArgName inp cursor))
`extQ` (refactorFortran inp cursor)
refactorFortran :: Monad m => [String] -> SrcLoc -> Fortran Annotation -> StateT Int m (String, SrcLoc, Bool)
refactorFortran inp cursor e = return $
if (pRefactored $ tag e) then
let (lb, ub) = srcSpan e
(p0, _) = takeBounds (cursor, lb) inp
outE = pprint e
lnl = case e of (NullStmt _ _) -> (if ((p0 /= []) && (Prelude.last p0 /= '\n')) then "\n" else "")
_ -> ""
lnl2 = if ((p0 /= []) && (Prelude.last p0 /= '\n')) then "\n" else ""
textOut = if p0 == "\n" then outE else (p0 ++ lnl2 ++ outE ++ lnl)
in (show $ Prelude.last p0) `trace` (textOut, ub, True)
else ("", cursor, False)
refactorDecl :: Monad m => [String] -> SrcLoc -> Decl Annotation -> StateT Int m (String, SrcLoc, Bool)
refactorDecl inp cursor d =
if (pRefactored $ tag d) then
let (lb, ub) = srcSpan d
(p0, _) = takeBounds (cursor, lb) inp
textOut = p0 ++ (pprint d)
in do textOut' <- -- The following compensates new lines with removed lines
case d of
(NullDecl _ _) ->
do added <- get
let diff = linesCovered ub lb
-- remove empty newlines here if extra lines have been added
let (text, removed) = if added <= diff
then removeNewLines textOut added
else removeNewLines textOut diff
put (added - removed)
return text
otherwise -> return textOut
return (textOut', ub, True)
else return ("", cursor, False)
refactorArgName :: Monad m => [String] -> SrcLoc -> ArgName Annotation -> m (String, SrcLoc, Bool)
refactorArgName inp cursor a = return $
case (refactored $ tag a) of
Just lb -> let (p0, _) = takeBounds (cursor, lb) inp
in (p0 ++ pprint a, lb, True)
Nothing -> ("", cursor, False)
refactorUses :: Monad m => [String] -> SrcLoc -> Uses Annotation -> StateT Int m (String, SrcLoc, Bool)
refactorUses inp cursor u =
let ?variant = HTMLPP in
case (refactored $ tag u) of
Just lb -> let (p0, _) = takeBounds (cursor, lb) inp
syntax = printSlave u
in do added <- get
if (newNode $ tag u) then put (added + (countLines syntax))
else return ()
return (p0 ++ syntax, toCol0 lb, True)
Nothing -> return ("", cursor, False)
countLines [] = 0
countLines ('\n':xs) = 1 + countLines xs
countLines (x:xs) = countLines xs
{- 'removeNewLines xs n' removes at most 'n' new lines characters from the input string
xs, returning the new string and the number of new lines that were removed. Note
that the number of new lines removed might actually be less than 'n'- but in principle
this should not happen with the usaage in 'refactorDecl' -}
removeNewLines [] n = ([], 0)
removeNewLines xs 0 = (xs, 0)
-- Deal with CR LF in the same way as just LF
removeNewLines ('\r':('\n':('\r':('\n':xs)))) n = let (xs', n') = removeNewLines ('\r':'\n':xs) (n - 1)
in (xs', n' + 1)
removeNewLines ('\n':('\n':xs)) n = let (xs', n') = removeNewLines ('\n':xs) (n - 1)
in (xs', n' + 1)
removeNewLines (x:xs) n = let (xs', n') = removeNewLines xs n
in (x:xs', n)
--removeNewLines ('\n':xs) 0 = let (xs', n') = removeNewLines xs 0
-- in ('\n':xs', 0)
{-
OLD (FLAKEY) ALGORITHM
reprint :: String -> String -> Program A1 -> String
reprint input f z = let input' = Prelude.lines input
in reprintA (SrcLoc f 1 0) (SrcLoc f (Prelude.length input') (1 + (Prelude.length $ Prelude.last input'))) input' (toZipper z)
doHole :: (Show (d A1)) => SrcLoc -> SrcLoc -> [String] -> Zipper (d A1) -> (String, SrcLoc)
doHole cursor end inp z = let ?variant = HTMLPP in
case (getHole z)::(Maybe (Fortran A1)) of
Just e -> let flag = tag e
(lb, ub) = srcSpan e
(p1, rest1) = takeBounds (cursor, lb) inp
in if flag then let ?variant = HTMLPP
in (p1 ++ printMaster e, ub)
else case (down' z) of
Just cz -> (p1 ++ reprintA lb ub rest1 cz, ub)
Nothing -> let (p2, _) = takeBounds (lb, ub) rest1
in (p1 ++ p2, ub)
Nothing -> case (down' z) of
Just cz -> "no - down\n" `trace` (reprintA cursor end inp cz, cursor)
Nothing -> ("", cursor)
reprintA :: (Show (d A1)) => SrcLoc -> SrcLoc -> [String] -> Zipper (d A1) -> String
reprintA cursor end inp z = let (p1, cursor') = doHole cursor end inp z
(p2, inp') = takeBounds (cursor, cursor') inp
in p1 ++ case (right z) of
Just rz -> reprintA cursor' end inp' rz
Nothing -> fst $ takeBounds (cursor', end) inp'
-}