{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Take in Haskell code and output a vector of source spans and -- their associated node type and case. module Main (main) where import Control.Applicative import Data.Data import Data.Maybe import Language.Haskell.Exts.Annotated import System.Environment -- | A generic Dynamic-like constructor -- but more convenient to -- write and pattern match on. data D = forall a. Data a => D a -- | A parser. Presently there is only 'parseTopLevel', but in the -- past, and in the future, there will be the facility to parse -- specific parse of declarations, rather than re-parsing the whole -- declaration which can be both slow and brittle. type Parser = ParseMode -> String -> ParseResult D -- | The 'empty' method isn't (shouldn't be) used, so this isn't a -- real Alternative instance (perhaps a Semigroup might do?). But it's -- handy. instance Alternative ParseResult where empty = ParseFailed undefined undefined ParseFailed{} <|> x = x x <|> _ = x --- | Main entry point. main :: IO () main = do code <- getContents action:typ:_ <- getArgs outputWith action typ code -- | Output some result with the given action (check/parse/etc.), -- parsing the given type of AST node. In the past, the type was any -- kind of AST node. Today, it's just a "decl" which is covered by -- 'parseTopLevel'. outputWith :: String -> String -> String -> IO () outputWith action typ code = case typ of "decl" -> output action parseTopLevel code "stmt" -> output action parseSomeStmt code _ -> error "Unknown parser type." -- | Output AST info for the given Haskell code. output :: String -> Parser -> String -> IO () output action parser code = case parser parseMode code of ParseFailed _ e -> error e ParseOk (D ast) -> case action of "check" -> return () "parse" -> putStrLn ("[" ++ concat (genHSE ast) ++ "]") _ -> error "unknown action" -- | An umbrella parser to parse: -- -- * A declaration. -- -- * An import line (not normally counted as a declaration). -- -- * A module header (not normally counted either). -- -- * A module pragma (normally part of the module header). -- parseTopLevel :: ParseMode -> String -> ParseResult D parseTopLevel mode code = D . fix <$> parseDeclWithMode mode code <|> D <$> parseImport mode code <|> D . fix <$> parseModuleWithMode mode code <|> D <$> parseModulePragma mode code -- | Parse a do-notation statement. parseSomeStmt :: ParseMode -> String -> ParseResult D parseSomeStmt mode code = D . fix <$> parseStmtWithMode mode code <|> D . fix <$> parseExpWithMode mode code <|> D <$> parseImport mode code fix ast = fromMaybe ast (applyFixities baseFixities ast) -- | Parse mode, includes all extensions, doesn't assume any fixities. parseMode :: ParseMode parseMode = defaultParseMode { extensions = allExtensions , fixities = Nothing } where allExtensions = filter isDisabledExtention knownExtensions isDisabledExtention (DisableExtension _) = False isDisabledExtention _ = True -- | Generate a list of spans from the HSE AST. genHSE :: Data a => a -> [String] genHSE x = case gmapQ D x of zs@(D y:ys) -> case cast y of Just s -> spanHSE (show (show (typeOf x))) (showConstr (toConstr x)) (srcInfoSpan s) : concatMap (\(i,D d) -> pre x i ++ genHSE d) (zip [0..] ys) _ -> concatMap (\(D d) -> genHSE d) zs _ -> [] -- | Pre-children tweaks for a given parent at index i. -- pre :: (Typeable a) => a -> Integer -> [String] pre x i = case cast x of -- }> becomes }>> Just (RecUpdate SrcSpanInfo{srcInfoPoints=(start:_),srcInfoSpan=end} _ _) | i == 1 -> [spanHSE (show "RecUpdates") "RecUpdates" (SrcSpan (srcSpanFilename start) (srcSpanStartLine start) (srcSpanStartColumn start) (srcSpanEndLine end) (srcSpanEndColumn end))] _ -> case cast x :: Maybe (Deriving SrcSpanInfo) of -- becomes ) Just (Deriving _ ds@(_:_)) -> [spanHSE (show "InstHeads") "InstHeads" (SrcSpan (srcSpanFilename start) (srcSpanStartLine start) (srcSpanStartColumn start) (srcSpanEndLine end) (srcSpanEndColumn end)) |Just (IHead (SrcSpanInfo start _) _ _) <- [listToMaybe ds] ,Just (IHead (SrcSpanInfo end _) _ _) <- [listToMaybe (reverse ds)]] _ -> [] -- | Generate a span from a HSE SrcSpan. spanHSE :: String -> String -> SrcSpan -> String spanHSE typ cons SrcSpan{..} = "[" ++ spanContent ++ "]" where unqualify = dropUntilLast '.' spanContent = unwords [unqualify typ ,cons ,show srcSpanStartLine ,show srcSpanStartColumn ,show srcSpanEndLine ,show srcSpanEndColumn] ------------------------------------------------------------------------------ -- General Utility -- | Like 'dropWhile', but repeats until the last match. dropUntilLast :: Char -> String -> String dropUntilLast ch = go [] where go _ (c:cs) | c == ch = go [] cs go acc (c:cs) = go (c:acc) cs go acc [] = reverse acc -------------------------------------------------------------------------------- -- Parsers that HSE hackage doesn't have parseImport :: ParseMode -> String -> ParseResult (ImportDecl SrcSpanInfo) parseImport mode code = case parseModuleWithMode mode code of ParseOk (Module _ _ _ [i] _) -> return i ParseOk _ -> ParseFailed noLoc "parseImport" ParseFailed x y -> ParseFailed x y parseModulePragma :: ParseMode -> String -> ParseResult (ModulePragma SrcSpanInfo) parseModulePragma mode code = case parseModuleWithMode mode (code ++ "\nmodule X where") of ParseOk (Module _ _ [p] _ _) -> return p ParseOk _ -> ParseFailed noLoc "parseModulePragma" ParseFailed x y -> ParseFailed x y