{-
   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 ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Camfort.Analysis.CommentAnnotator
  ( annotateComments
  , isComment
  , ASTEmbeddable(..)
  , Linkable(..)
  ) where


import Data.Data (Data)
import Data.Generics.Uniplate.Operations

import Language.Fortran.AST
import Language.Fortran.Util.Position

import Camfort.Specification.Parser ( looksLikeASpec
                                    , runParser
                                    , SpecParseError
                                    , SpecParser)

annotateComments :: forall m e a ast .
  (Monad m, Data a, Linkable a, ASTEmbeddable a ast)
  => SpecParser e ast
  -> (SrcSpan -> SpecParseError e -> m ())
  -> ProgramFile a
  -> m (ProgramFile a)
annotateComments :: SpecParser e ast
-> (SrcSpan -> SpecParseError e -> m ())
-> ProgramFile a
-> m (ProgramFile a)
annotateComments SpecParser e ast
parser SrcSpan -> SpecParseError e -> m ()
handleErr ProgramFile a
pf = do
    ProgramFile a
pf' <- (ProgramUnit a -> m (ProgramUnit a))
-> ProgramFile a -> m (ProgramFile a)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM ProgramUnit a -> m (ProgramUnit a)
writeASTProgramUnits (ProgramFile a -> m (ProgramFile a))
-> m (ProgramFile a) -> m (ProgramFile a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Block a -> m (Block a)) -> ProgramFile a -> m (ProgramFile a)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Block a -> m (Block a)
writeASTBlocks ProgramFile a
pf
    ProgramFile a -> m (ProgramFile a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgramFile a -> m (ProgramFile a))
-> (ProgramFile a -> ProgramFile a)
-> ProgramFile a
-> m (ProgramFile a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ProgramUnit a] -> [ProgramUnit a])
-> ProgramFile a -> ProgramFile a
forall from to. Biplate from to => (to -> to) -> from -> from
descendBi (Data a, Linkable a) => [ProgramUnit a] -> [ProgramUnit a]
[ProgramUnit a] -> [ProgramUnit a]
linkProgramUnits (ProgramFile a -> m (ProgramFile a))
-> ProgramFile a -> m (ProgramFile a)
forall a b. (a -> b) -> a -> b
$ ([Block a] -> [Block a]) -> ProgramFile a -> ProgramFile a
forall from to. Biplate from to => (to -> to) -> from -> from
descendBi (Data a, Linkable a) => [Block a] -> [Block a]
[Block a] -> [Block a]
linkBlocks ProgramFile a
pf'
  where
    writeAST :: a -> f a -> SrcSpan -> String -> m (f a)
writeAST a
a f a
d SrcSpan
srcSpan String
comment =
      if SpecParser e ast -> String -> Bool
forall e r. SpecParser e r -> String -> Bool
looksLikeASpec SpecParser e ast
parser String
comment
      then case SpecParser e ast -> String -> Either (SpecParseError e) ast
forall e r. SpecParser e r -> String -> Either (SpecParseError e) r
runParser SpecParser e ast
parser String
comment of
             Left  SpecParseError e
err -> SrcSpan -> SpecParseError e -> m ()
handleErr SrcSpan
srcSpan SpecParseError e
err m () -> m (f a) -> m (f a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
d
             Right ast
ast -> f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> m (f a)) -> f a -> m (f a)
forall a b. (a -> b) -> a -> b
$ a -> f a -> f a
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation (a -> ast -> a
forall a ast. ASTEmbeddable a ast => a -> ast -> a
annotateWithAST a
a ast
ast) f a
d
      else f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
d

    writeASTProgramUnits :: ProgramUnit a -> m (ProgramUnit a)
    writeASTProgramUnits :: ProgramUnit a -> m (ProgramUnit a)
writeASTProgramUnits pu :: ProgramUnit a
pu@(PUComment a
a SrcSpan
srcSpan (Comment String
comment)) =
      a -> ProgramUnit a -> SrcSpan -> String -> m (ProgramUnit a)
forall (f :: * -> *) a.
(Annotated f, ASTEmbeddable a ast) =>
a -> f a -> SrcSpan -> String -> m (f a)
writeAST a
a ProgramUnit a
pu SrcSpan
srcSpan String
comment
    writeASTProgramUnits ProgramUnit a
pu = ProgramUnit a -> m (ProgramUnit a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramUnit a
pu

    writeASTBlocks :: Block a -> m (Block a)
    writeASTBlocks :: Block a -> m (Block a)
writeASTBlocks b :: Block a
b@(BlComment a
a SrcSpan
srcSpan (Comment String
comment)) =
      a -> Block a -> SrcSpan -> String -> m (Block a)
forall (f :: * -> *) a.
(Annotated f, ASTEmbeddable a ast) =>
a -> f a -> SrcSpan -> String -> m (f a)
writeAST a
a Block a
b SrcSpan
srcSpan String
comment
    writeASTBlocks Block a
b = Block a -> m (Block a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block a
b

    -- | Link all comments to first non-comment in the list.
    joinComments :: [f b] -> [f b]
joinComments [ ] = [ ]
    joinComments dss :: [f b]
dss@(f b
d:[f b]
ds)
      | f b -> Bool
forall a. HasComment a => a -> Bool
isComment f b
d =
        let ([f b]
comments, [f b]
rest) = (f b -> Bool) -> [f b] -> ([f b], [f b])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span f b -> Bool
forall a. HasComment a => a -> Bool
isComment [f b]
dss
            -- Given a list of comments and a list of non-comment blocks which occur
            -- afterward in the code, then link them together (either forward or backward)
            -- returning a pair of processed blocks and unprocessed blocks

            -- pre-condition: first parameter is a list of comments

            -- default uses 'link' to associate every comment to the first following block
            linkMulti :: ([f b], [f b])
linkMulti = ((f b -> f b) -> [f b] -> [f b]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> b) -> f b -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> b) -> f b -> f b) -> (b -> b) -> f b -> f b
forall a b. (a -> b) -> a -> b
$ (b -> f b -> b) -> f b -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> f b -> b
forall (a :: * -> *) b. (Linked a, Linkable b) => b -> a b -> b
linker ([f b] -> f b
forall a. [a] -> a
head [f b]
rest)) [f b]
comments, [f b]
rest)
        in if [f b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [f b]
rest -- Does the group end with comments
             then [f b]
comments
             else let ([f b]
procs, [f b]
unprocs) = ([f b], [f b])
linkMulti
                  in [f b]
procs [f b] -> [f b] -> [f b]
forall a. [a] -> [a] -> [a]
++ [f b] -> [f b]
joinComments [f b]
unprocs
      | Bool
otherwise = ([f b] -> [f b]) -> f b -> f b
forall from to. Biplate from to => (to -> to) -> from -> from
descendBi [f b] -> [f b]
joinComments f b
d
                    f b -> [f b] -> [f b]
forall a. a -> [a] -> [a]
: [f b] -> [f b]
joinComments [f b]
ds

    {-| Link all comment blocks to first non-comment block in the list. |-}
    linkBlocks :: (Data a, Linkable a) => [ Block a ] -> [ Block a ]
    linkBlocks :: [Block a] -> [Block a]
linkBlocks = [Block a] -> [Block a]
forall (f :: * -> *) b.
(Data (f b), HasComment (f b), Functor f, Linked f, Linkable b) =>
[f b] -> [f b]
joinComments

    {-| Link all comment 'program units' to first non-comment program unit in the list. |-}
    linkProgramUnits :: (Data a, Linkable a) => [ ProgramUnit a ] -> [ ProgramUnit a ]
    linkProgramUnits :: [ProgramUnit a] -> [ProgramUnit a]
linkProgramUnits = [ProgramUnit a] -> [ProgramUnit a]
forall (f :: * -> *) b.
(Data (f b), HasComment (f b), Functor f, Linked f, Linkable b) =>
[f b] -> [f b]
joinComments

class ASTEmbeddable a ast where
  annotateWithAST :: a -> ast -> a

-- | Instances of this class can be combined with 'Block' and 'ProgramUnit'.
class Linkable a where
  -- ^ Combine an @a@ with a 'Block'
  link   :: a   -> Block a -> a
  -- ^ Combine an @a@ with a 'ProgramUnit'
  linkPU :: a -> ProgramUnit a -> a

-- | Interface for types that can be combined with 'Linkable' types.
class Linked a where
  linker :: (Linkable b) => b -> a b -> b

instance Linked Block where
  linker :: b -> Block b -> b
linker = b -> Block b -> b
forall b. Linkable b => b -> Block b -> b
link

instance Linked ProgramUnit where
  linker :: b -> ProgramUnit b -> b
linker = b -> ProgramUnit b -> b
forall b. Linkable b => b -> ProgramUnit b -> b
linkPU

-- | Interface for types that can have comments.
class HasComment a where
  isComment :: a -> Bool

instance HasComment (Block a) where
  isComment :: Block a -> Bool
isComment BlComment{} = Bool
True
  isComment Block a
_           = Bool
False

instance HasComment (ProgramUnit a) where
  isComment :: ProgramUnit a -> Bool
isComment PUComment{} = Bool
True
  isComment ProgramUnit a
_           = Bool
False