diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Main.hs | 48 | ||||
| -rw-r--r-- | Parser.hs | 182 | ||||
| -rw-r--r-- | Pattern.hs | 31 | ||||
| -rw-r--r-- | Pretty.hs | 12 | ||||
| -rw-r--r-- | SourceFile.hs | 37 | ||||
| -rw-r--r-- | refactor-type-parameters.cabal | 19 |
7 files changed, 330 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c33954f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ @@ -0,0 +1,48 @@ +{-# LANGUAGE LambdaCase #-} +module Main where + +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as T +import System.Environment +import System.Exit + +import Pattern +import Parser +import Pretty +import SourceFile + + +apply :: Pattern -> SourceFile -> SourceFile +apply pat (SourceFile chunks) = + SourceFile $ flip map chunks $ \case CSkip s -> CSkip s + COcc occ -> COcc (apply' pat occ) + +apply' :: Pattern -> Occurrence -> Occurrence +apply' (Pattern name items) origocc@(Occurrence name' args) + | name == name' = Occurrence name' (travOrigsArgs items args) + | otherwise = origocc + +travOrigsArgs :: [Origin] -> [(Text, Text)] -> [(Text, Text)] +travOrigsArgs [] args = args +travOrigsArgs _ [] = [] +travOrigsArgs (OCopy : items) (arg:args) = arg : travOrigsArgs items args +travOrigsArgs (ONew name : items) args = (T.pack " ", name) : travOrigsArgs items args + +main :: IO () +main = do + getArgs >>= \case + [fname, pat] -> do + pat' <- case parsePattern pat of + Left err -> die err + Right pat' -> return pat' + source <- readFile fname + parsed <- case parseSourceFile fname source pat' of + Left err -> die (show err) + Right res -> return res + print parsed + T.putStrLn (pretty parsed) + putStrLn (replicate 80 '-') + T.putStrLn (pretty (apply pat' parsed)) + _ -> do + die "Usage: refactor-type-parameters <file.hs> <OpenAcc env aenv *taenv t>" diff --git a/Parser.hs b/Parser.hs new file mode 100644 index 0000000..afc5b15 --- /dev/null +++ b/Parser.hs @@ -0,0 +1,182 @@ +module Parser ( + parseSourceFile, +) where + +import Control.Monad +import Control.Monad.Reader +import Data.Char +import Data.Either +import Data.List (intersperse) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy.Builder as B +import Data.Text.Lazy.Builder (Builder) +import Text.Parsec + +import Pattern +import SourceFile + + +type Parser = ParsecT String () (Reader Pattern) +type Parser' = Parsec String () + +parseSourceFile :: FilePath -> String -> Pattern -> Either ParseError SourceFile +parseSourceFile fname source pat = runReader (runParserT pSourceFile () fname source) pat + +pSourceFile :: Parser SourceFile +pSourceFile = do + SourceFile . concat <$> many (pDataDef <|> pInstanceDef <|> pFunDef <|> skipLine) + where + skipLine :: Parser [Chunk] + skipLine = + fmap (pure . CSkip . build) $ + (\s -> B.fromString (s ++ "\n")) <$> manyTill anyChar newline + +-- Parses a function definition on the current line. +-- Assumes the cursor is at the start of a line, and ends at the start of a line again. +-- Fails if no function definition can be found on this line. +pFunDef :: Parser [Chunk] +pFunDef = try $ do + prefix <- build <$> combine + [horSpaces + ,option mempty (text "=" +++ horSpaces) + ,option mempty (text "let" +++ horSpaces1) + ,option mempty (text "where" +++ horSpaces1)] + let indent = T.length prefix + s1 <- combine + [pIdentifier + ,horSpaces + ,text "::"] + let limiter = lookAhead $ try $ do + _ <- newline + _ <- atmost (fromIntegral indent) (char ' ') + _ <- satisfy (not . isSpace) + return () + typeText <- manyTill anyChar limiter + s2 <- B.singleton <$> newline + pat <- ask + return (CSkip (prefix `T.append` build s1) : parseTypeText pat typeText ++ [CSkip (build s2)]) + +pDataDef :: Parser [Chunk] +pDataDef = try $ do + s1 <- text "data" + let limiter = lookAhead $ try $ + choice [eof + ,do _ <- newline + _ <- lookAhead (satisfy (not . isSpace)) + notFollowedBy (string "--")] + typeText <- manyTill anyChar limiter + s2 <- (eof >> return mempty) <|> (B.singleton <$> newline) + pat <- ask + return (CSkip (build s1) : parseTypeText pat typeText ++ [CSkip (build s2)]) + +pInstanceDef :: Parser [Chunk] +pInstanceDef = try $ do + s1 <- text "instance" + let limiter = lookAhead $ try $ + choice [eof + ,lookAhead $ try $ do + _ <- satisfy prewordc + _ <- string "where" + eof <|> (satisfy prewordc >> return ())] + typeText <- manyTill anyChar limiter + pat <- ask + return (CSkip (build s1) : parseTypeText pat typeText) + +parseTypeText :: Pattern -> String -> [Chunk] +parseTypeText (Pattern patname _) inputText = + fromRight [CSkip (T.pack inputText)] $ + parse pTypeText "" inputText + where + pTypeText :: Parser' [Chunk] + pTypeText = do + s1 <- manyTill anyChar $ + try (choice [eof + ,lookAhead $ try $ do + _ <- satisfy prewordc + _ <- string (T.unpack patname) + return ()]) + choice [eof >> return [CSkip (T.pack s1)] + ,do s2 <- B.singleton <$> satisfy prewordc + sName <- build <$> text (T.unpack patname) + -- Try to parse some arguments; if that fails wholesale, just ignore this occurrence + choice [do args <- try (many pArgument) + rest <- pTypeText + return (CSkip (build (B.fromString s1 <> s2)) + :COcc (Occurrence sName args) + :rest) + ,do rest <- pTypeText + return (CSkip (build (B.fromString s1 <> s2)) + :CSkip sName + :rest)]] + + -- Returns preceding spaces and the argument itself. Requires non-zero spacing before. + pArgument :: Parser' (Text, Text) + pArgument = try $ do + s1 <- build <$> horSpaces1 + s2 <- build <$> pExprAtom + return (s1, s2) + + pExprAtom :: Parser' Builder + pExprAtom = pName <|> pParens + where + pExprApp :: Parser' Builder + pExprApp = pExprAtom +++ (mconcat <$> many (try (horSpaces1 +++ pExprAtom))) + + pParens :: Parser' Builder + pParens = try $ + combine [text "(" + ,mconcat . intersperse (B.singleton ',') <$> + (horSpaces +++ pExprApp) `sepBy` char ',' + ,horSpaces + ,text ")"] + +prewordc :: Char -> Bool +prewordc c = not (isAlpha c) && not (isDigit c) && c /= '_' + +pIdentifier :: Parser Builder +pIdentifier = pOperator <|> pName + where + pOperator :: Parser Builder + pOperator = try $ combine + [text "(" + ,do s <- many1 (satisfy (\c -> isSymbol c && c `notElem` "()")) + guard (not (all (== '-') s)) + return (B.fromString s) + ,text ")"] + +pName :: Monad m => ParsecT String u m Builder +pName = try $ do + c1 <- satisfy (\c -> isAlpha c || c == '_') + cs <- many $ satisfy (\c -> isAlpha c || isDigit c || c `elem` "_'") + guard (not (reservedName (c1 : cs))) + return (B.fromString (c1 : cs)) + where + reservedName :: String -> Bool + reservedName s = s `elem` + ["case", "class", "data", "default", "deriving", "do", "else" + ,"foreign", "if", "import", "in", "infix", "infixl", "infixr" + ,"instance", "let", "module", "newtype", "of", "then", "type" + ,"where", "_"] + +horSpaces :: Monad m => ParsecT String u m Builder +horSpaces = mconcat . map B.singleton <$> many (satisfy (== ' ')) + +horSpaces1 :: Monad m => ParsecT String u m Builder +horSpaces1 = mconcat . map B.singleton <$> many1 (satisfy (== ' ')) + +text :: Monad m => String -> ParsecT String u m Builder +text s = B.fromString <$> string s + +atmost :: Int -> ParsecT s u m a -> ParsecT s u m [a] +atmost 0 _ = return [] +atmost n p = ((:) <$> p <*> atmost (n-1) p) <|> return [] + +(+++) :: ParsecT s u m Builder -> ParsecT s u m Builder -> ParsecT s u m Builder +p +++ q = (<>) <$> p <*> q + +combine :: (Monoid m, Applicative f) => [f m] -> f m +combine = fmap mconcat . sequenceA + +build :: Builder -> Text +build = B.toLazyText diff --git a/Pattern.hs b/Pattern.hs new file mode 100644 index 0000000..2a6007d --- /dev/null +++ b/Pattern.hs @@ -0,0 +1,31 @@ +module Pattern where + +import Data.Char +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T + + +data Pattern = Pattern Text [Origin] + deriving (Show) + +data Origin = OCopy + | ONew Text + deriving (Show) + +parsePattern :: String -> Either String Pattern +parsePattern str = do + (constr, args) <- case words str of + [] -> Left "Empty match pattern" + constr : args -> return (constr, args) + args' <- traverse parseArg args + return (Pattern (T.pack constr) args') + where + parseArg :: String -> Either String Origin + parseArg ('*':name) | isValid name = Right (ONew (T.pack name)) + | otherwise = Left ("Invalid type param name '" ++ name ++ "'") + parseArg name | isValid name = Right OCopy + | otherwise = Left ("Invalid type param name '" ++ name ++ "'") + + isValid :: String -> Bool + isValid "" = False + isValid (hd:cs) = isLower hd && all (\c -> isAlpha c || c `elem` "'_") cs diff --git a/Pretty.hs b/Pretty.hs new file mode 100644 index 0000000..a5b65a6 --- /dev/null +++ b/Pretty.hs @@ -0,0 +1,12 @@ +module Pretty where + +import qualified Data.Text.Lazy.Builder as B +import Data.Text.Lazy.Builder (Builder) +import Data.Text.Lazy (Text) + + +class Pretty a where + pretty' :: a -> Builder + + pretty :: a -> Text + pretty = B.toLazyText . pretty' diff --git a/SourceFile.hs b/SourceFile.hs new file mode 100644 index 0000000..0a054c0 --- /dev/null +++ b/SourceFile.hs @@ -0,0 +1,37 @@ +module SourceFile where + +import qualified Data.Text.Lazy.Builder as B +import Data.Text.Lazy.Builder (Builder) +import Data.Text.Lazy (Text) + +import Pretty + + +data SourceFile = SourceFile [Chunk] + deriving (Show) + +data Chunk = CSkip Text + | COcc Occurrence + deriving (Show) + +data Occurrence = Occurrence + { occName :: Text + , occArgs :: [(Text, Text)] } -- prefix spacing, argument value + deriving (Show) + +instance Pretty SourceFile where + pretty' (SourceFile cs) = mconcat (map pretty' cs) + +instance Pretty Chunk where + pretty' (CSkip s) = B.fromLazyText s + pretty' (COcc occ) = pretty' occ + +instance Pretty Occurrence where + pretty' (Occurrence name args) = + ansiBG '1' (B.fromLazyText name) + <> mconcat [ansiBG '4' (B.fromLazyText pre) + <> ansiBG '3' (B.fromLazyText val) + | (pre, val) <- args] + where + ansiBG :: Char -> Builder -> Builder + ansiBG c b = B.fromString ("\x1B[1;4" ++ c : "m") <> b <> B.fromString "\x1B[0m" diff --git a/refactor-type-parameters.cabal b/refactor-type-parameters.cabal new file mode 100644 index 0000000..63e7395 --- /dev/null +++ b/refactor-type-parameters.cabal @@ -0,0 +1,19 @@ +cabal-version: 2.0 +name: refactor-type-parameters +synopsis: Refactor type parameters of a Haskell type +version: 0.0.1.0 +license: MIT +author: Tom Smeding +maintainer: tom@tomsmeding.com +build-type: Simple + +executable refactor-type-parameters + main-is: Main.hs + other-modules: Pattern, SourceFile, Parser, Pretty + build-depends: base >= 4.13 && < 4.15, + mtl, + parsec, + text + hs-source-dirs: . + default-language: Haskell2010 + ghc-options: -Wall -O2 -threaded -rtsopts |