{-
   Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish

   Licensed under the Apache License, Version 2.0 (the "License");
   you may not use this file except in compliance with the License.
   You may obtain a copy of the License at

       http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS,
   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   See the License for the specific language governing permissions and
   limitations under the License.
-}

{-# LANGUAGE RankNTypes #-}

module Camfort.Reprint
  ( reprint
  , subtext
  , takeBounds
  ) where

import Data.Generics.Zipper

import Camfort.Helpers

import qualified Data.ByteString.Char8 as B
import Data.Data
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.Class (lift)
import qualified Language.Fortran.Util.Position as FU

{-
Reminder:
 -- type SourceText    = B.ByteString
 -- data FU.Position = FU.Position { posAsbsoluteOffset :: Int,
                                     posColumn :: Int,
                                     posLine   :: Int }
-}


-- A refactoring takes a 'Typeable' value
-- into a stateful SourceText (B.ByteString) transformer,
-- which returns a pair of a stateful computation of an updated SourceText
-- paired with a boolean flag denoting whether a refactoring has been
-- performed.  The state contains a FU.Position which is the "cursor"
-- within the original source text. The incoming value corresponds to
-- the position of the first character in the input SourceText. The
-- outgoing value is a cursor ahead of the incoming one which shows
-- the amount of SourceText that is consumed by the refactoring.

type Refactored = Bool
type Refactoring m =
  forall b . Typeable b
         => b -> SourceText -> StateT FU.Position m (SourceText, Refactored)

-- The reprint algorithm takes a refactoring (parameteric in
-- some monad m) and turns an arbitrary pretty-printable type 'p'
-- into a monadic SourceText transformer.

reprint :: (Monad m, Data p)
        => Refactoring m -> p -> SourceText -> m SourceText
reprint :: Refactoring m -> p -> SourceText -> m SourceText
reprint Refactoring m
refactoring p
tree SourceText
input
  -- If the inupt is null then null is returned
  | SourceText -> Bool
B.null SourceText
input = SourceText -> m SourceText
forall (m :: * -> *) a. Monad m => a -> m a
return SourceText
B.empty
  -- Otherwise go with the normal algorithm
  | Bool
otherwise = do
   -- Create an initial cursor at the start of the file
   let cursor0 :: Position
cursor0 = Position
FU.initPosition
   -- Enter the top-node of a zipper for 'tree'
   -- setting the cursor at the start of the file
   (SourceText
out, (Position
_, SourceText
remaining)) <- StateT (Position, SourceText) m SourceText
-> (Position, SourceText) -> m (SourceText, (Position, SourceText))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Refactoring m
-> Zipper p -> StateT (Position, SourceText) m SourceText
forall (m :: * -> *) a.
Monad m =>
Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
enter Refactoring m
refactoring (p -> Zipper p
forall a. Data a => a -> Zipper a
toZipper p
tree)) (Position
cursor0, SourceText
input)
   -- Add to the output source the reamining input source
   SourceText -> m SourceText
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceText -> m SourceText) -> SourceText -> m SourceText
forall a b. (a -> b) -> a -> b
$ SourceText
out SourceText -> SourceText -> SourceText
`B.append` SourceText
remaining

-- The enter, enterDown, enterRight each take a refactoring and a
-- zipper producing a stateful computation with (FU.Position, SourceText)
-- state.

enter, enterDown, enterRight
  :: Monad m
  => Refactoring m -> Zipper a -> StateT (FU.Position, SourceText) m SourceText

-- `enter` applies the generic refactoring to the current context
-- of the zipper
enter :: Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
enter Refactoring m
refactoring Zipper a
z = do

  -- Part 1.
  -- Apply a refactoring
  (Position
cursor, SourceText
inp)     <- StateT (Position, SourceText) m (Position, SourceText)
forall (m :: * -> *) s. Monad m => StateT s m s
get
  ((SourceText
p1, Bool
refactored), Position
cursor') <- m ((SourceText, Bool), Position)
-> StateT (Position, SourceText) m ((SourceText, Bool), Position)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ((SourceText, Bool), Position)
 -> StateT (Position, SourceText) m ((SourceText, Bool), Position))
-> m ((SourceText, Bool), Position)
-> StateT (Position, SourceText) m ((SourceText, Bool), Position)
forall a b. (a -> b) -> a -> b
$ StateT Position m (SourceText, Bool)
-> Position -> m ((SourceText, Bool), Position)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (GenericQ (StateT Position m (SourceText, Bool))
-> Zipper a -> StateT Position m (SourceText, Bool)
forall b a. GenericQ b -> Zipper a -> b
query (a -> SourceText -> StateT Position m (SourceText, Bool)
Refactoring m
`refactoring` SourceText
inp) Zipper a
z) Position
cursor

  -- Part 2.
  SourceText
p2 <- if Bool
refactored
        then do
          -- If the node was refactored then...
          -- cut out the portion of source text consumed by the refactoring
          (SourceText
_, SourceText
inp') <- (SourceText, SourceText)
-> StateT (Position, SourceText) m (SourceText, SourceText)
forall (m :: * -> *) a. Monad m => a -> m a
return ((SourceText, SourceText)
 -> StateT (Position, SourceText) m (SourceText, SourceText))
-> (SourceText, SourceText)
-> StateT (Position, SourceText) m (SourceText, SourceText)
forall a b. (a -> b) -> a -> b
$ (Position, Position) -> SourceText -> (SourceText, SourceText)
takeBounds (Position
cursor, Position
cursor') SourceText
inp
          (Position, SourceText) -> StateT (Position, SourceText) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Position
cursor', SourceText
inp')
          SourceText -> StateT (Position, SourceText) m SourceText
forall (m :: * -> *) a. Monad m => a -> m a
return SourceText
B.empty
        else do
          -- If a refactoring was not output,
          -- enter the children of the current context
          (Position, SourceText) -> StateT (Position, SourceText) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Position
cursor', SourceText
inp)
          Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
forall (m :: * -> *) a.
Monad m =>
Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
enterDown Refactoring m
refactoring Zipper a
z

  -- Part 3.
  -- Enter the right sibling of the current context
  SourceText
p3 <- Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
forall (m :: * -> *) a.
Monad m =>
Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
enterRight Refactoring m
refactoring Zipper a
z

  -- Concat the output for the current context, children, and right sibling
  SourceText -> StateT (Position, SourceText) m SourceText
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceText -> StateT (Position, SourceText) m SourceText)
-> SourceText -> StateT (Position, SourceText) m SourceText
forall a b. (a -> b) -> a -> b
$ [SourceText] -> SourceText
B.concat [SourceText
p1, SourceText
p2, SourceText
p3]

-- `enterDown` navigates to the children of the current context
enterDown :: Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
enterDown Refactoring m
refactoring Zipper a
z =
  case Zipper a -> Maybe (Zipper a)
forall a. Zipper a -> Maybe (Zipper a)
down' Zipper a
z of
    -- Go to children
    Just Zipper a
dz -> Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
forall (m :: * -> *) a.
Monad m =>
Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
enter Refactoring m
refactoring Zipper a
dz
    -- No children
    Maybe (Zipper a)
Nothing -> SourceText -> StateT (Position, SourceText) m SourceText
forall (m :: * -> *) a. Monad m => a -> m a
return SourceText
B.empty

-- `enterRight` navigates to the right sibling of the current context
enterRight :: Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
enterRight Refactoring m
refactoring Zipper a
z =
  case Zipper a -> Maybe (Zipper a)
forall a. Zipper a -> Maybe (Zipper a)
right Zipper a
z of
    -- Go to right sibling
    Just Zipper a
rz -> Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
forall (m :: * -> *) a.
Monad m =>
Refactoring m
-> Zipper a -> StateT (Position, SourceText) m SourceText
enter Refactoring m
refactoring Zipper a
rz
    -- No right sibling
    Maybe (Zipper a)
Nothing -> SourceText -> StateT (Position, SourceText) m SourceText
forall (m :: * -> *) a. Monad m => a -> m a
return SourceText
B.empty

-- Given a lower-bound and upper-bound pair of FU.Positions, split the
-- incoming SourceText based on the distanceF between the FU.Position pairs
takeBounds :: (FU.Position, FU.Position) -> SourceText -> (SourceText, SourceText)
takeBounds :: (Position, Position) -> SourceText -> (SourceText, SourceText)
takeBounds (Position
l, Position
u) = (Int, Int)
-> (Int, Int)
-> (Int, Int)
-> SourceText
-> (SourceText, SourceText)
subtext (Int
ll, Int
lc) (Int
ll, Int
lc) (Int
ul, Int
uc)
  where (FU.Position Int
_ Int
lc Int
ll String
_ Maybe (Int, String)
_) = Position
l
        (FU.Position Int
_ Int
uc Int
ul String
_ Maybe (Int, String)
_) = Position
u

{-|
  Split a text.

  Returns a tuple containing:
    1. the bit of input text between upper and lower bounds
    2. the remaining input text

  Takes:
    1. current cursor position
    2. lower bound
    3. upper bound
    4. input text

-}
subtext :: (Int, Int) -> (Int, Int) -> (Int, Int) -> B.ByteString -> (B.ByteString, B.ByteString)
subtext :: (Int, Int)
-> (Int, Int)
-> (Int, Int)
-> SourceText
-> (SourceText, SourceText)
subtext (Int, Int)
cursor (Int
lowerLn, Int
lowerCol) (Int
upperLn, Int
upperCol) =
    SourceText -> (Int, Int) -> SourceText -> (SourceText, SourceText)
subtext' SourceText
B.empty (Int, Int)
cursor
  where
    subtext' :: SourceText -> (Int, Int) -> SourceText -> (SourceText, SourceText)
subtext' SourceText
acc (Int
cursorLn, Int
cursorCol) SourceText
input

      | Int
cursorLn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lowerLn Bool -> Bool -> Bool
&& (Int
cursorCol Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lowerCol Bool -> Bool -> Bool
==> Int
cursorLn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lowerLn) =
        case SourceText -> Maybe (Char, SourceText)
B.uncons SourceText
input of
          Maybe (Char, SourceText)
Nothing -> (SourceText -> SourceText
B.reverse SourceText
acc, SourceText
input)
          Just (Char
'\n', SourceText
input') -> SourceText -> (Int, Int) -> SourceText -> (SourceText, SourceText)
subtext' SourceText
acc (Int
cursorLnInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
1) SourceText
input'
          Just (Char
_, SourceText
input')    -> SourceText -> (Int, Int) -> SourceText -> (SourceText, SourceText)
subtext' SourceText
acc (Int
cursorLn, Int
cursorColInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) SourceText
input'

      | Int
cursorLn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
upperLn Bool -> Bool -> Bool
&& (Int
cursorCol Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
upperCol Bool -> Bool -> Bool
==> Int
cursorLn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
upperLn) =
        case SourceText -> Maybe (Char, SourceText)
B.uncons SourceText
input of
          Maybe (Char, SourceText)
Nothing -> (SourceText -> SourceText
B.reverse SourceText
acc, SourceText
input)
          Just (Char
'\n', SourceText
input') -> SourceText -> (Int, Int) -> SourceText -> (SourceText, SourceText)
subtext' (Char -> SourceText -> SourceText
B.cons Char
'\n' SourceText
acc) (Int
cursorLnInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
1) SourceText
input'
          Just (Char
x, SourceText
input')    -> SourceText -> (Int, Int) -> SourceText -> (SourceText, SourceText)
subtext' (Char -> SourceText -> SourceText
B.cons Char
x SourceText
acc) (Int
cursorLn, Int
cursorColInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) SourceText
input'

      | Bool
otherwise =
        (SourceText -> SourceText
B.reverse SourceText
acc, SourceText
input)

-- | Logical implication operator.
(==>) :: Bool -> Bool -> Bool; infix 2 ==>
Bool
a ==> :: Bool -> Bool -> Bool
==> Bool
b = Bool
a Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
<= Bool
b