{- 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 FlexibleInstances, UndecidableInstances, ImplicitParams, DoAndIfThenElse, MultiParamTypeClasses, FlexibleContexts, KindSignatures, ScopedTypeVariables, DeriveGeneric, DeriveDataTypeable #-} {- Provides support for outputting source files and analysis information -} module Camfort.Output where import Camfort.Helpers import Camfort.Traverse import qualified Language.Fortran.AST as F import qualified Language.Fortran.Util.Position as FU import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Parser as Fortran import Language.Fortran import Language.Fortran.Pretty import Language.Fortran.PreProcess import Camfort.Analysis.Annotations import Camfort.Analysis.Syntax import Camfort.PrettyPrint import Camfort.Reprint import Camfort.Transformation.Syntax import Camfort.Specification.Units.Environment import System.FilePath import System.Directory -- FIXME: Did enough to get this module to compile, it's not optimised to use ByteString. import qualified Data.ByteString.Char8 as B import Data.Map.Lazy hiding (map, foldl) import Data.Functor.Identity import Data.Generics import GHC.Generics import Data.List hiding (zip) import Data.Generics.Uniplate.Data import Generics.Deriving.Copoint import Data.Char import Data.Generics.Zipper import Data.Maybe import Debug.Trace import Text.Printf import Control.Monad.Trans.Class import Control.Monad.Trans.State.Lazy -- Custom 'Show' which on strings is the identity class Show' s where show' :: s -> String instance {-# OVERLAPS #-} Show' String where show' = id instance {-# OVERLAPS #-} (Show' a, Show' b) => Show' (a, b) where show' (a, b) = "(" ++ show' a ++ "," ++ show' b ++")" instance {-# OVERLAPPABLE #-} (Show a) => Show' a where show' = show class OutputFiles t where {-| Given a directory and list of triples of filenames, with their source text (if it exists) and their AST, write these to the directory -} mkOutputText :: FileOrDir -> t -> SourceText outputFile :: t -> Filename outputFiles :: FileOrDir -> FileOrDir -> [t] -> IO () outputFiles inp outp pdata = do outIsDir <- isDirectory outp inIsDir <- isDirectory inp inIsFile <- doesFileExist inp if outIsDir then do createDirectoryIfMissing True outp putStrLn $ "Writing refactored files to directory: " ++ outp ++ "/" isdir <- isDirectory inp let inSrc = if isdir then inp else getDir inp mapM_ (\x -> let f' = changeDir outp inSrc (outputFile x) in do checkDir f' putStrLn $ "Writing " ++ f' B.writeFile f' (mkOutputText outp x)) pdata else if inIsDir || length pdata > 1 then error $ "Error: attempting to output multiple files, but the \ \given output destination is a single file. \n\ \Please specify an output directory" else if inIsFile -- Input was just a file, then output just a file then do putStrLn $ "Writing refactored file to: " ++ outp putStrLn $ "Writing " ++ outp B.writeFile outp (mkOutputText outp (head pdata)) else let outSrc = getDir outp in do createDirectoryIfMissing True outSrc putStrLn $ "Writing refactored file to: " ++ outp putStrLn $ "Writing " ++ outp B.writeFile outp (mkOutputText outp (head pdata)) -- When the new source text is already provided instance OutputFiles (Filename, SourceText) where mkOutputText _ (_, output) = output outputFile (f, _) = f data PR a = PR (Program a) deriving Data instance PrettyPrint (PR Annotation) where prettyPrint (PR x) = prettyPrint x -- When there is a file to be reprinted (for refactoring) instance OutputFiles (Filename, SourceText, Program Annotation) where mkOutputText f' (f, input, ast') = evalState (reprint refactoringLF (PR ast') input) 0 where outputFile (f, _, _) = f -- When there is a file to be reprinted (for refactoring) instance OutputFiles (Filename, SourceText, F.ProgramFile Annotation) where mkOutputText f' (f, input, ast') = runIdentity $ reprint refactoringForPar ast' input outputFile (f, _, _) = f srcSpanToSrcLocs :: FU.SrcSpan -> (SrcLoc, SrcLoc) srcSpanToSrcLocs (FU.SrcSpan lpos upos) = (toSrcLoc lpos, toSrcLoc upos) where toSrcLoc pos = SrcLoc { srcFilename = "" , srcLine = FU.posLine pos , srcColumn = FU.posColumn pos } instance (PrettyPrint (F.ProgramFile Annotation)) where -- STUB prettyPrint _ = B.empty refactoringForPar :: (Typeable a) => a -> SourceText -> StateT SrcLoc Identity (SourceText, Bool) refactoringForPar z inp = ((\_ -> return (B.empty, False)) `extQ` (flip outputComments inp)) $ z where outputComments :: F.Block Annotation -> SourceText -> StateT SrcLoc Identity (SourceText, Bool) outputComments e@(F.BlComment ann span comment) inp = do cursor <- get if (pRefactored ann) then let (lb, ub) = srcSpanToSrcLocs span lb' = leftOne lb (p0, _) = takeBounds (cursor, lb') inp nl = if comment == [] then B.empty else B.pack "\n" in put ub >> return (B.concat [p0, B.pack comment, nl], True) else return (B.empty, False) where leftOne (SrcLoc f l c) = SrcLoc f (l-1) (c-1) outputComments _ _ = return (B.empty, False) {-| changeDir is used to change the directory of a filename string. If the filename string has no directory then this is an identity -} changeDir newDir oldDir oldFilename = newDir ++ (listDiffL oldDir oldFilename) where listDiffL [] ys = ys listDiffL xs [] = [] listDiffL (x:xs) (y:ys) | x==y = listDiffL xs ys | otherwise = ys {-| output pre-analysis ASTs into the directory with the given file names (the list of ASTs should match the list of filenames) -} outputAnalysisFiles :: FileOrDir -> [Program Annotation] -> [Filename] -> IO () outputAnalysisFiles src asts files = do isdir <- isDirectory src let src' = if isdir then src else dropFileName src putStrLn $ "Writing analysis files to directory: " ++ src' mapM (\(ast', f) -> writeFile (f ++ ".html") ((concatMap outputHTML) ast')) (zip asts files) return () {- Specifies how to do specific refactorings (uses generic query extension - remember extQ is non-symmetric) -} refactoringLF :: (Typeable a) => a -> SourceText -> StateT SrcLoc (State Int) (SourceText, Bool) refactoringLF = flip $ \inp -> ((((\_ -> return (B.empty, False)) `extQ` (refactorUses inp)) `extQ` (refactorDecl inp)) `extQ` (refactorArgName inp)) `extQ` (refactorFortran inp) refactorFortran :: Monad m => SourceText -> Fortran Annotation -> StateT SrcLoc m (SourceText, Bool) refactorFortran inp e = do cursor <- get if (pRefactored $ tag e) then let (lb, ub) = srcSpan e (p0, _) = takeBounds (cursor, lb) inp outE = B.pack $ pprint e lnl = case e of (NullStmt _ _) -> (if ((p0 /= B.empty) && (B.last p0 /= '\n')) then B.pack "\n" else B.empty) _ -> B.empty lnl2 = if ((p0 /= B.empty) && (B.last p0 /= '\n')) then B.pack "\n" else B.empty textOut = if p0 == (B.pack "\n") then outE else B.concat [p0, lnl2, outE, lnl] in put ub >> return (textOut, True) else return (B.empty, False) refactorDecl :: SourceText -> Decl Annotation -> StateT SrcLoc (State Int) (SourceText, Bool) refactorDecl inp d = do cursor <- get if (pRefactored $ tag d) then let (lb, ub) = srcSpan d (p0, _) = takeBounds (cursor, lb) inp textOut = p0 `B.append` (B.pack $ pprint d) in do textOut' <- -- The following compensates new lines with removed lines case d of (NullDecl _ _) -> do added <- lift 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 lift $ put (added - removed) return text otherwise -> return textOut put ub return (textOut', True) else return (B.empty, False) refactorArgName :: Monad m => SourceText -> ArgName Annotation -> StateT SrcLoc m (SourceText, Bool) refactorArgName inp a = do cursor <- get case (refactored $ tag a) of Just lb -> do let (p0, _) = takeBounds (cursor, lb) inp put lb return (p0 `B.append` (B.pack $ pprint a), True) Nothing -> return (B.empty, False) refactorUses :: SourceText -> Uses Annotation -> StateT SrcLoc (State Int) (SourceText, Bool) refactorUses inp u = do cursor <- get let ?variant = HTMLPP in case (refactored $ tag u) of Just lb -> let (p0, _) = takeBounds (cursor, lb) inp syntax = B.pack $ printSlave u in do added <- lift get if (newNode $ tag u) then lift $ put (added + (countLines syntax)) else return () put $ toCol0 lb return (p0 `B.append` syntax, True) Nothing -> return (B.empty, False) countLines xs = case B.uncons xs of Nothing -> 0 Just ('\n', xs) -> 1 + countLines xs Just (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 xs 0 = (xs, 0) -- Deal with CR LF in the same way as just LF removeNewLines xs n = case unpackFst (B.splitAt 4 xs) of ("\r\n\r\n", xs) -> (xs', n' + 1) where (xs', n') = removeNewLines ((B.pack "\r\n") `B.append` xs) (n - 1) _ -> case unpackFst (B.splitAt 2 xs) of ("\n\n", xs) -> (xs', n' + 1) where (xs', n') = removeNewLines ((B.pack "\n") `B.append` xs) (n - 1) _ -> case B.uncons xs of Nothing -> (xs, 0) Just (x, xs) -> (B.cons x xs', n) where (xs', n') = removeNewLines xs n unpackFst (x, y) = (B.unpack x, y) --removeNewLines ('\n':xs) 0 = let (xs', n') = removeNewLines xs 0 -- in ('\n':xs', 0)