Frames-0.7.4: test/PrettyTH.hs

{-# LANGUAGE OverloadedStrings #-}
module PrettyTH where
import Data.Char (isSpace)
import Frames
import Language.Haskell.TH
import Language.Haskell.TH.PprLib
import Text.PrettyPrint
import Text.Regex.Applicative

import Temp

generateCode :: String -> String -> Q Exp
generateCode rowName txt =
    withTempContents
      txt
      (\fp -> tableTypes rowName fp
              >>= stringE
              . makePretty
              . renderStyle (style {ribbonsPerLine=1.0, lineLength=150})
              . to_HPJ_Doc . ppr)

-- | Make template haskell-generated code more readable by
-- unqualifying common names, making type operators infix, erasing
-- inferable types, and adding a bit of whitespace.
makePretty :: String -> String
makePretty = -- Add new lines before type synonym definitions
             replace' "\ntype " "\n\ntype "
             -- Make :-> and ': type operators infix
             . (!! 10) . iterate (replace infixCons)
             . replace infixNil
             . replace infixCol
               -- Erase inferable type
             . replace ((\x y -> x ++ " ∈ " ++ y)
                        <$> ("RElem " *> some (psym (not . isSpace)))
                        <*> ((some (psym isSpace) *> some (psym (not . isSpace)))
                             <* " (RIndex " <* some (psym (/= ')')) <* ")"))
               -- Unqualify names
             . replace' "Frames.CSV.ParserOptions" "ParserOptions"
             . replace' "GHC.Maybe." ""
             . replace' "GHC.Base." ""
             . replace' "GHC.Types." ""
             . replace' "Data.Vinyl.Core." ""
             . replace' "Data.Vinyl.Derived." ""
             . replace' "Data.Vinyl.Lens." ""
             . replace' "Data.Vinyl.TypeLevel." ""
             . replace' "Frames.Rec." ""
             . replace' "Frames.RecLens." ""
             . replace' "Data.Proxy." ""
             . replace' "Data.Text." "T."
             . replace' "Data.Text.Internal." "T."
             . replace' "'GHC.Types.:" "(':)"
  where replace' orig replacement = replace (replacement <$ string orig)
        infixCol = (\x y -> '"' : x ++ "\" :-> " ++ y)
                   <$> ("(Frames.Col.:->) \"" *> (some (psym (/= '"'))) <* "\""
                        <* some (psym isSpace))
                   <*> some (psym (/= ' '))
        infixNil = (\x -> '[' : x ++ "]")
                   <$> ("('(:) " *> some (psym (/= ' '))
                        <* some (psym isSpace) <* "'[])")
        infixCons = (\x y -> '[' : x ++ ", " ++ y ++ "]")
                    <$> ("('(:) " *> some (psym (/= ' '))
                         <* some (psym isSpace) <* "[")
                    <*> (some (psym (/= ']')) <* "])")