{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
module Camfort.Analysis.CommentAnnotator
( annotateComments
, isComment
, ASTEmbeddable(..)
, Linkable(..)
) where
import Data.Data (Data)
import Data.Generics.Uniplate.Data
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)
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 a. a -> m 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 a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> f a -> m (f a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
d
Right ast
ast -> f a -> m (f a)
forall a. a -> m 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 a. 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 a. a -> m 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 a. a -> m 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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block a
b
linkBlocks :: (Data a, Linkable a) => [ Block a ] -> [ Block a ]
linkBlocks :: (Data a, Linkable a) => [Block a] -> [Block a]
linkBlocks = [Block a] -> [Block a]
forall (f :: * -> *) a.
(HasComment (f a), Linked f, Linkable a, Functor f, Data (f a)) =>
[f a] -> [f a]
joinComments
linkProgramUnits :: (Data a, Linkable a) => [ ProgramUnit a ] -> [ ProgramUnit a ]
linkProgramUnits :: (Data a, Linkable a) => [ProgramUnit a] -> [ProgramUnit a]
linkProgramUnits = [ProgramUnit a] -> [ProgramUnit a]
forall (f :: * -> *) a.
(HasComment (f a), Linked f, Linkable a, Functor f, Data (f a)) =>
[f a] -> [f a]
joinComments
joinComments
:: forall f a. (HasComment (f a), Linked f, Linkable a, Functor f, Data (f a))
=> [f a] -> [f a]
[ ] = [ ]
joinComments dss :: [f a]
dss@(f a
d:[f a]
ds)
| f a -> Bool
forall a. HasComment a => a -> Bool
isComment f a
d =
let ([f a]
comments, [f a]
rest) = (f a -> Bool) -> [f a] -> ([f a], [f a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span f a -> Bool
forall a. HasComment a => a -> Bool
isComment [f a]
dss
linkMulti :: ([f a], [f a])
linkMulti = ((f a -> f a) -> [f a] -> [f a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a) -> f a -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> f a -> f a) -> (a -> a) -> f a -> f a
forall a b. (a -> b) -> a -> b
$ (a -> f a -> a) -> f a -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> f a -> a
forall b. Linkable b => b -> f b -> b
forall (a :: * -> *) b. (Linked a, Linkable b) => b -> a b -> b
linker ([f a] -> f a
forall a. HasCallStack => [a] -> a
head [f a]
rest)) [f a]
comments, [f a]
rest)
in if [f a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [f a]
rest
then [f a]
comments
else let ([f a]
procs, [f a]
unprocs) = ([f a], [f a])
linkMulti
in [f a]
procs [f a] -> [f a] -> [f a]
forall a. [a] -> [a] -> [a]
++ [f a] -> [f a]
forall (f :: * -> *) a.
(HasComment (f a), Linked f, Linkable a, Functor f, Data (f a)) =>
[f a] -> [f a]
joinComments [f a]
unprocs
| Bool
otherwise = forall from to. Biplate from to => (to -> to) -> from -> from
descendBi @(f a) @[f a] [f a] -> [f a]
forall (f :: * -> *) a.
(HasComment (f a), Linked f, Linkable a, Functor f, Data (f a)) =>
[f a] -> [f a]
joinComments f a
d f a -> [f a] -> [f a]
forall a. a -> [a] -> [a]
: [f a] -> [f a]
forall (f :: * -> *) a.
(HasComment (f a), Linked f, Linkable a, Functor f, Data (f a)) =>
[f a] -> [f a]
joinComments [f a]
ds
class ASTEmbeddable a ast where
annotateWithAST :: a -> ast -> a
class Linkable a where
link :: a -> Block a -> a
linkPU :: a -> ProgramUnit a -> a
class Linked a where
linker :: (Linkable b) => b -> a b -> b
instance Linked Block where
linker :: forall b. Linkable b => b -> Block b -> b
linker = b -> Block b -> b
forall b. Linkable b => b -> Block b -> b
link
instance Linked ProgramUnit where
linker :: forall b. Linkable b => b -> ProgramUnit b -> b
linker = b -> ProgramUnit b -> b
forall b. Linkable b => b -> ProgramUnit b -> b
linkPU
class a where
:: 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