1
1
mirror of https://github.com/github/semantic.git synced 2024-12-22 14:21:31 +03:00

Play with a different parse output

This commit is contained in:
Timothy Clem 2016-12-08 08:11:49 -08:00
parent 093bb62904
commit 3b676d9f31
2 changed files with 30 additions and 1 deletions

View File

@ -11,6 +11,7 @@ import qualified Data.Text.ICU.Convert as Convert
import qualified Data.Text.ICU.Detect as Detect
import Data.Record
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Info
import Language
import Language.Markdown
@ -31,6 +32,34 @@ data ParseJSON = ParseJSON
, children :: [ParseJSON]
} deriving (Show, Generic, ToJSON)
run2 :: Arguments -> IO ()
run2 Arguments{..} = do
sources <- sequence $ readAndTranscodeFile <$> filePaths
terms <- zipWithM (\parser sourceBlob -> parser sourceBlob) parsers (sourceBlobs sources)
writeToOutput output (cata algebra <$> terms)
where
sourceBlobs sources = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob)
parsers = parserWithSource <$> filePaths
algebra :: TermF (Syntax leaf) (Record '[SourceText, Range, Category, SourceSpan]) Text -> Text
algebra term = case term of
(annotation :< Leaf _) -> "(" <> category' annotation <> ")"
(annotation :< syntax@(Indexed _)) -> "(" <> category' annotation <> toChildList syntax <> ")"
(annotation :< syntax) -> "\n(" <> category' annotation <> toChildList syntax <> ")"
where
category' = toS . Info.category
toChildList syntax = case toList syntax of
[] -> ""
xs -> " " <> T.unwords xs
writeToOutput :: Maybe FilePath -> [Text] -> IO ()
writeToOutput output text =
case output of
Nothing -> for_ text putStrLn
Just path -> for_ text (T.writeFile path)
run :: Arguments -> IO ()
run Arguments{..} = do
sources <- sequence $ readAndTranscodeFile <$> filePaths

View File

@ -32,7 +32,7 @@ main = do
args@Arguments{..} <- programArguments =<< execParser argumentsParser
case runMode of
Diff -> runDiff args
Parse -> Parse.run args
Parse -> Parse.run2 args
runDiff :: Arguments -> IO ()
runDiff args@Arguments{..} = case diffMode of