HListPP-0.2: HListPP.hs

{-# LANGUAGE QuasiQuotes, ViewPatterns #-}
module Main where

import Control.Applicative.QQ.ADo
import Data.Char
import Data.List
import Data.Monoid
import System.Environment
import Text.Regex.Applicative
import Control.Exception
import System.Exit
import System.IO

-- "ModuleName."
modNameDot = [ado|
    m <- psym isUpper
    odName <- many (psym isAlpha)
    dot <- sym '.'
    m:odName ++ [dot] |]

-- "M.Od.Ule.Name.something"
qualIdent = [ado|
    modNames <- many modNameDot
    end <- some (psym isAlpha)
    concat (modNames ++ [end]) |]

takeQual x = case findLongestPrefix qualIdent x of
    Just (a , '`' : rest) -> ('`' : a ++ "`", rest) -- `infix`
    Just (a, rest) -> (addLabel a,rest)             -- `ident
    Nothing -> ("``", x) -- unlikely

addLabel xu = "(hLens' (Label :: Label \""++xu++"\"))"

main = do
  args <- getArgs
  operate args
    `catch` \ (SomeException e) -> do
          hPutStrLn stderr (show e)
          hPutStrLn stderr ("in: HListPP " ++ unwords args)
          exitFailure

{-# INLINE operate #-}
operate [originalFileName, inputFile, outputFile] = do
    input <- readFile inputFile
    let linePragma = "{-# LINE 1 \"" <> originalFileName <> "\" #-}\n"
    writeFile outputFile (linePragma <> s input)
operate args = error $ "usage: HListPP originalFileName inputFile outputFile\
  \ also: \
  \ {-# OPTIONS_GHC -F -pgmF HListPP #-}\
  \ called with arguments: " ++ show args

-- | applies takeQual outside of characters, strings, comments
{-# INLINE s #-}
s (stripPrefix "'\"'" -> Just xs) = "'\"'" ++ s xs
s (stripPrefix "'`'"  -> Just xs) = "'`'"  ++ s xs
s (stripPrefix "{-" -> Just xs) = "{-" ++ cl xs
s (stripPrefix "--" -> Just xs)
        | x1 : _ <- xs, isSymbol x1 = "--" ++ s xs
        | otherwise = "-- " ++ cs xs
s ('"': xs) = '"' : t xs
s ('`':  (takeQual -> (a,xs))) = a ++ s xs
s (x:xs) = x : s xs
s [] = []

-- | inside string
{-# INLINE t #-}
t (stripPrefix "\\\"" -> Just xs) = "\\\"" ++ t xs
t ('"' : xs) = '"' : s xs
t (x:xs) = x : t xs
t [] = error "expected \""

-- | inside multiline comment
cl (stripPrefix "-}" -> Just xs) = "-}" ++ s xs
cl (x:xs) = x:cl xs
cl [] = error "expected -}"

-- | inside single line comment
cs ('\n':xs) = '\n' : s xs
cs (x:xs) = x : cs xs
cs "" = ""