{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- |Illustrates the usage of MRSOP with a custom -- opaque type universe and the use of HDiff to -- compute diffs over various languages. -- module Main (main) where import System.IO import System.Exit import Control.Monad import Control.Applicative import Data.Foldable (asum) import Development.GitRev import Options.Applicative import Data.Semigroup ((<>)) import Data.Maybe (isJust) import qualified Data.List as L (lookup) import Data.Type.Equality import Generics.MRSOP.Base hiding (Infix) import Generics.MRSOP.HDiff.Renderer import Generics.MRSOP.HDiff.Digest import qualified Generics.MRSOP.GDiff as GDiff import qualified Data.HDiff.Patch as D import qualified Data.HDiff.Diff as D import qualified Data.HDiff.Patch.Merge as D import qualified Data.HDiff.Patch.TreeEditDistance as TED import Data.HDiff.Patch.Show import qualified Data.HDiff.Change as D import qualified Data.HDiff.Change.TreeEditDistance as TEDC import Languages.Interface import qualified Languages.While as While import qualified Languages.Lines as Lines #ifdef ENABLE_LUA_SUPPORT import qualified Languages.Lua as Lua #endif #ifdef ENABLE_CLOJURE_SUPPORT import qualified Languages.Clojure as Clj #endif -- |The parsers that we support mainParsers :: [LangParser] mainParsers = [LangParser "while" (fmap (dfrom . into @While.FamStmt) . While.parseFile) #ifdef ENABLE_LUA_SUPPORT ,LangParser "lua" (fmap (dfrom . into @Lua.FamStmt) . Lua.parseFile) #endif #ifdef ENABLE_CLOJURE_SUPPORT ,LangParser "clj" (fmap (dfrom . into @Clj.FamExpr) . Clj.parseFile) #endif ,LangParser "lines" (fmap (dfrom . into @Lines.FamStmt) . Lines.parseFile) ] --------------------------- -- * Cmd Line Options data PatchOrChange = Patch | Chg deriving (Eq , Show) data Options = AST { optFileA :: FilePath } | GDiff { optFileA :: FilePath , optFileB :: FilePath , showES :: Bool } | Diff { optFileA :: FilePath , optFileB :: FilePath , testApply :: Bool , minHeight :: Int , diffMode :: D.DiffMode , opqHandling :: D.DiffOpaques , toEditScript :: Maybe PatchOrChange , showES :: Bool } | Merge { optFileA :: FilePath , optFileO :: FilePath , optFileB :: FilePath , minHeight :: Int , diffMode :: D.DiffMode , opqHandling :: D.DiffOpaques } deriving (Eq , Show) astOpts :: Parser Options astOpts = AST <$> argument str (metavar "FILE") showesOpt :: Parser Bool showesOpt = switch (long "show-es" <> help "Display the generated edit script" <> hidden) minheightOpt :: Parser Int minheightOpt = option auto $ long "min-height" <> short 'm' <> showDefault <> value 1 <> metavar "INT" <> help "Minimum height of subtrees considered for sharing" <> hidden readmOneOf :: [(String, a)] -> ReadM a readmOneOf = maybeReader . flip L.lookup diffmodeOpt :: Parser D.DiffMode diffmodeOpt = option (readmOneOf [("proper" , D.DM_ProperShare) ,("nonest" , D.DM_NoNested) ,("patience", D.DM_Patience) ]) ( long "diff-mode" <> short 'd' <> metavar "proper | nonest | patience ; default: proper" <> value D.DM_ProperShare <> help aux <> hidden) where aux = unwords ["Controls how context extraction works. If you are unaware about how" ,"this works, check 'Data.HDiff.Diff.Types' and 'Data.HDiff.Diff.Modes'" ,"for more information." ] opqhandlingOpt :: Parser D.DiffOpaques opqhandlingOpt = option (readmOneOf [("never" , D.DO_Never) ,("spine" , D.DO_OnSpine) ,("always", D.DO_AsIs) ]) ( long "diff-opq" <> short 'k' <> metavar "never | spine | always ; default: spine" <> value D.DO_OnSpine <> help aux <> hidden) where aux = unwords ["Controls how to handle opaque values. We either treat them like normal" ,"trees, with 'always', never share them, or share only the opaque values" ,"that end up on the spine" ] toesOpt :: Parser (Maybe PatchOrChange) toesOpt = flag' (Just Patch) ( long "patch-to-es" <> help "Translates a patch to an edit script at the patch level" <> hidden) <|> flag' (Just Chg) ( long "change-to-es" <> help ("Translates a patch to an edit script at the change" ++ " level; does so by using distrCChange on the patch") <> hidden) <|> pure Nothing gdiffOpts :: Parser Options gdiffOpts = GDiff <$> argument str (metavar "OLDFILE") <*> argument str (metavar "NEWFILE") <*> showesOpt diffOpts :: Parser Options diffOpts = Diff <$> argument str (metavar "OLDFILE") <*> argument str (metavar "NEWFILE") <*> switch ( long "test-apply" -- TODO: check this doc <> help "Attempts application; returns ExitFailure if apply fails." <> hidden) <*> minheightOpt <*> diffmodeOpt <*> opqhandlingOpt <*> toesOpt <*> showesOpt mergeOpts :: Parser Options mergeOpts = Merge <$> argument str (metavar "MYFILE") <*> argument str (metavar "OLDFILE") <*> argument str (metavar "YOURFILE") <*> minheightOpt <*> diffmodeOpt <*> opqhandlingOpt parseOptions :: Parser Options parseOptions = hsubparser ( command "ast" (info astOpts (progDesc "Parses and displays an ast")) <> command "gdiff" (info gdiffOpts (progDesc "Runs Generics.MRSOP.GDiff on the targets")) <> command "diff" (info diffOpts (progDesc "Runs Data.HDiff.Diff on the targes")) <> command "merge" (info mergeOpts (progDesc "Runs the merge algorithm on the specified files")) ) <|> diffOpts data Verbosity = Quiet | Normal | Loud | VeryLoud deriving (Eq, Show) verbosity :: Parser Verbosity verbosity = asum [ flag' Quiet ( long "quiet" <> short 'q' <> help "Runs on quiet mode; almost no information out" <> hidden ) , flag' Loud ( long "verbose" <> short 'v' <> help "Runs with a more output than normal" <> hidden ) , flag' VeryLoud ( long "debug" <> internal ) , pure Normal ] data OptionMode = OptAST | OptDiff | OptMerge | OptGDiff deriving (Eq , Show) optionMode :: Options -> OptionMode optionMode (AST _) = OptAST optionMode (GDiff _ _ _) = OptGDiff optionMode (Merge _ _ _ _ _ _) = OptMerge optionMode (Diff _ _ _ _ _ _ _ _) = OptDiff main :: IO () main = execParser fullOpts >>= \(verb , opts) -> case optionMode opts of OptAST -> mainAST verb opts OptDiff -> mainDiff verb opts OptGDiff -> mainGDiff verb opts OptMerge -> mainMerge verb opts >>= exitWith where fullOpts = info ((,) <$> verbosity <*> parseOptions <**> helper) $ fullDesc <> header ("digem v0.0.0 [" ++ $(gitBranch) ++ "@" ++ $(gitHash) ++ "]") <> progDesc "Runs digem with the specified command, 'diff' is the default command." <> footer "Run digem COMMAND --help for more help on specific commands" putStrLnErr :: String -> IO () putStrLnErr = hPutStrLn stderr -- * Generic interface mainAST :: Verbosity -> Options -> IO ExitCode mainAST v opts = withParsed1 mainParsers (optFileA opts) $ \fa -> do unless (v == Quiet) $ putStrLn (show (renderFix renderHO fa)) return ExitSuccess -- |Applies a patch to an element and either checks it is equal to -- another element, or returns the result. tryApply :: (EqHO ki , ShowHO ki , TestEquality ki , IsNat ix, RendererHO ki ,HasDatatypeInfo ki fam codes) => Verbosity -> D.Patch ki codes ix -> Fix ki codes ix -> Maybe (Fix ki codes ix) -> IO (Maybe (Fix ki codes ix)) tryApply v patch fa fb = case D.apply patch fa of Left err -> hPutStrLn stderr "!! apply failed" >> hPutStrLn stderr (" " ++ err) >> when (v == Loud) (hPutStrLn stderr (show $ renderFix renderHO fa)) >> exitFailure Right b' -> return $ maybe (Just b') (const Nothing) fb -- |Runs our diff algorithm with particular options parsed -- from the CLI options. diffWithOpts :: ( EqHO ki , ShowHO ki , TestEquality ki , IsNat ix, RendererHO ki , DigestibleHO ki, HasDatatypeInfo ki fam codes) => Options -> Fix ki codes ix -> Fix ki codes ix -> IO (D.Patch ki codes ix) diffWithOpts opts fa fb = do let localopts = D.DiffOptions (minHeight opts) (opqHandling opts) (diffMode opts) return (D.diffOpts localopts fa fb) mainGDiff :: Verbosity -> Options -> IO ExitCode mainGDiff _ opts = withParsed2 mainParsers (optFileA opts) (optFileB opts) $ \fa fb -> do let es = GDiff.diff' fa fb putStrLn ("tree-edit-distance: " ++ show (GDiff.cost es)) when (showES opts) (putStrLn $ show es) return ExitSuccess mainDiff :: Verbosity -> Options -> IO ExitCode mainDiff v opts = withParsed2 mainParsers (optFileA opts) (optFileB opts) $ \fa fb -> do patch <- diffWithOpts opts fa fb unless (v == Quiet) $ displayRawPatch stdout patch when (testApply opts) $ void (tryApply v patch fa (Just fb)) when (isJust (toEditScript opts)) $ do let (role , ees) = case toEditScript opts of Just Patch -> ("patch" , TED.toES patch (NA_I fa)) Just Chg -> ("change", TEDC.toES (D.distrCChange patch) (NA_I fa)) case ees of Left err -> putStrLnErr ("!! " ++ err) Right es -> putStrLn ("tree-edit-distance: " ++ role ++ " " ++ show (GDiff.cost es)) >> when (v == Loud) (putStrLn $ show es) return ExitSuccess mainMerge :: Verbosity -> Options -> IO ExitCode mainMerge v opts = withParsed3 mainParsers (optFileA opts) (optFileO opts) (optFileB opts) $ \fa fo fb -> do when (v == Loud) $ do putStrLnErr $ "O: " ++ optFileO opts putStrLnErr $ "A: " ++ optFileA opts putStrLnErr $ "B: " ++ optFileB opts patchOA <- diffWithOpts opts fo fa patchOB <- diffWithOpts opts fo fb let resAB = patchOA D.// patchOB let resBA = patchOB D.// patchOA when (v == VeryLoud) $ do putStrLnErr $ "O->A/O->B " ++ replicate 55 '#' displayPatchC stderr resAB putStrLnErr $ "O->B/O->A " ++ replicate 55 '#' displayPatchC stderr resBA case (,) <$> D.noConflicts resAB <*> D.noConflicts resBA of Nothing -> putStrLnErr " !! Conflicts O->A/O->B !!" >> putStrLnErr (unlines (map (" - " ++) (D.getConflicts resAB))) >> putStrLnErr " !! Conflicts O->B/O->A !!" >> putStrLnErr (unlines (map (" - " ++) (D.getConflicts resBA))) >> return (ExitFailure 1) Just (ab , ba) -> do when (v == Loud) (putStrLnErr "!! apply ba fa") Just fb' <- tryApply v ba fa Nothing when (v == Loud) (putStrLnErr "!! apply ab fb") Just fa' <- tryApply v ab fb Nothing if eqFix eqHO fb' fa' then return ExitSuccess else return (ExitFailure 2)