Initial

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/
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..d52fedc
--- /dev/null
+++ b/Main.hs
@@ -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