module Text.Reprinter
(
reprintSort
, reprint
, Source
, Position
, initPosition
, initLine
, initCol
, mkLine
, mkCol
, advanceLine
, advanceCol
, Span
, Reprinting
, catchAll
, genReprinting
, Refactorable(..)
, RefactorType(..)
) where
import Control.Monad (forM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Lazy
import qualified Data.Text.Lazy as Text
import Data.Data
import Data.Generics.Zipper
import Data.Monoid ((<>), mempty)
import Data.List (sortOn)
type Source = Text.Text
newtype Line = Line Int deriving (Data, Eq, Ord, Show)
initLine :: Line
initLine = Line 1
mkLine :: Int -> Either String Line
mkLine l
| l < 1 = Left $ "mkLine: called with: " <> show l <> ". Minimum is 1."
| otherwise = Right (Line l)
newtype Col = Col Int deriving (Data, Eq, Ord, Show)
initCol :: Col
initCol = Col 1
mkCol :: Int -> Either String Col
mkCol l
| l < 1 = Left $ "mkCol: called with: " <> show l <> ". Minimum is 1."
| otherwise = Right (Col l)
type Position = (Line,Col)
initPosition :: Position
initPosition = (initLine,initCol)
advanceLine :: Position -> Position
advanceLine (Line x, _) = (Line (x+1), initCol)
advanceCol :: Position -> Position
advanceCol (ln, Col x) = (ln, Col (x+1))
type Span = (Position, Position)
type Reprinting m = forall node . Typeable node => node -> m (Maybe (RefactorType, Source, Span))
data RefactorType = Before | After | Replace
deriving Show
reprint :: (Monad m, Data ast) => Reprinting m -> ast -> Source -> m Source
reprint reprinting ast input
| Text.null input = return mempty
| otherwise = do
let state_0 = (initPosition, input)
let comp = enter reprinting (toZipper ast)
(out, (_, remaining)) <- runStateT comp state_0
return (out <> remaining)
enter :: Monad m => Reprinting m -> Zipper ast -> StateT (Position, Source) m Source
enter reprinting zipper = do
refactoringInfo <- lift (query reprinting zipper)
output <- case refactoringInfo of
Nothing -> go down'
Just r -> splice r
outputSib <- go right
return (output <> outputSib)
where
go direction =
case direction zipper of
Just zipper -> enter reprinting zipper
Nothing -> return mempty
reprintSort :: (Monad m, Data ast) => Reprinting m -> ast -> Source -> m Source
reprintSort reprinting ast input
| Text.null input = return mempty
| otherwise = do
let state_0 = (initPosition, input)
let comp = enter' reprinting (toZipper ast)
(out, (_, remaining)) <- runStateT comp state_0
return (out <> remaining)
enter' :: Monad m => Reprinting m -> Zipper ast
-> StateT (Position, Source) m Source
enter' reprinting zipper = do
rs <- lift $ getRefactorings reprinting zipper []
srcs <- mapM splice (sortBySpan . reverse $ rs)
return $ Text.concat srcs
where
sortBySpan = sortOn (\(_,_,sp) -> sp)
getRefactorings :: Monad m => Reprinting m -> Zipper ast -> [(RefactorType, Source, Span)]
-> m [(RefactorType, Source, Span)]
getRefactorings reprinting zipper acc = do
refactoringInfo <- query reprinting zipper
acc <- case refactoringInfo of
Nothing -> go down' acc
Just r -> return (r : acc)
acc <- go right acc
return acc
where
go direction acc =
case direction zipper of
Just zipper -> getRefactorings reprinting zipper acc
Nothing -> return acc
splice :: Monad m => (RefactorType, Source, Span) -> StateT (Position, Source) m Source
splice (typ, output, (lb, ub)) = do
(cursor, inp) <- get
case typ of
Replace -> do
let (pre, inp') = splitBySpan (cursor, lb) inp
let (_, inp'') = splitBySpan (lb, ub) inp'
put (ub, inp'')
return (pre <> output)
After -> do
let (pre, inp') = splitBySpan (cursor, ub) inp
put (ub, inp')
return (pre <> output)
Before -> do
let (pre, inp') = splitBySpan (cursor, lb) inp
let (post, inp'') = splitBySpan (lb, ub) inp'
put (ub, inp'')
return (pre <> output <> post)
splitBySpan :: Span -> Source -> (Source, Source)
splitBySpan (lower, upper) =
subtext mempty lower
where
subtext acc cursor input
| cursor < lower =
case Text.uncons input of
Nothing -> done
Just ('\n', input') -> subtext acc (advanceLine cursor) input'
Just (_, input') -> subtext acc (advanceCol cursor) input'
| cursor < upper =
case Text.uncons input of
Nothing -> done
Just ('\n', input') -> subtext (Text.cons '\n' acc) (advanceLine cursor) input'
Just (x, input') -> subtext (Text.cons x acc) (advanceCol cursor) input'
| otherwise = done
where done = (Text.reverse acc, input)
class Refactorable t where
isRefactored :: t -> Maybe RefactorType
getSpan :: t -> Span
genReprinting :: (Monad m, Refactorable t, Typeable t)
=> (t -> m Source) -> t -> m (Maybe (RefactorType, Source, Span))
genReprinting f z = case isRefactored z of
Nothing -> return Nothing
Just refactorType -> do
output <- f z
return $ Just (refactorType, output, getSpan z)
catchAll :: Monad m => a -> m (Maybe b)
catchAll _ = return Nothing