HListPP-0.1: 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

-- "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 = operate =<< getArgs

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

-- | applies takeQual outside of characters, strings
{-# INLINE s #-}
s (stripPrefix "'\"'" -> Just xs) = "'\"'" ++ s xs
s (stripPrefix "'`'"  -> Just xs) = "'`'"  ++ s 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