tup-functor-0.1: preprocessor/tpp.hs

-- | Tuple brackets preprocessor.
-- Use like this:
-- 
-- > {-# OPTIONS -F -pgmF tuplepp #-}
--
-- Write code like this:
--
-- > x = {{a,b,c}}
--
-- and it will be translated to this:
--
-- > x = Tup3 a b c 
-- 
{-# LANGUAGE PackageImports #-}
module Main where

--------------------------------------------------------------------------------

import Data.Char

import Language.Haskell.Exts
import "parsec2" Text.ParserCombinators.Parsec

import System.Environment

-- import Debug.Trace
-- debug x = trace (show x)

--------------------------------------------------------------------------------

tupleCon :: Int -> Exp
tupleCon k = Var $ UnQual $ Ident ("Tup" ++ show k)

toTupleE :: Exp -> Exp
toTupleE e = case e of
  Tuple es -> foldl App (tupleCon (length es)) es
  _        -> App (tupleCon 1) e

inparens :: String -> String
inparens s = "(" ++ s ++ ")"

toTupleS :: String -> String
toTupleS s = {- trace ("|"++s++"|") $ -} case parseExp (inparens s) of
  ParseOk e -> pp (toTupleE e)
  err       -> error ("parse error in idiom bracket:\n" ++ show err)

pp :: Pretty a => a -> String
pp = prettyPrintStyleMode style mode where
  mode = defaultMode
    { layout = PPNoLayout
    }
  style = Style 
    { mode = LeftMode -- OneLineMode
    , lineLength = 1000
    , ribbonsPerLine = 1.5
    }
  
--------------------------------------------------------------------------------

data TupleLine 
  = S String
  | I TupleLine (Bool,TupleLine) TupleLine      -- pre (isTuple,bracket) post
  deriving Show

{-
xinit :: TupleLine -> TupleLine
xinit (S str) = S (init str)
xinit (I pre mid post) = I pre mid (xinit post)

xtail :: TupleLine -> TupleLine
xtail (S str) = S (tail str)
xtail (I pre mid post) = I (xtail pre) mid post
-}

lineP :: Parser TupleLine
lineP = do
  pre <- many (noneOf "{}")  
  m <- optionMaybe $ do

    char '{'
    c <- lookAhead anyChar
    mid <- case c of
      '{' -> char '{' >> lineP
      _   -> lineP

    char '}'
    d <- lookAhead anyChar
    post <- case d of
      '}' -> char '}' >> lineP
      _   -> lineP

    let b = (c=='{') && (d=='}') -- True -- if isAlphaNum c || elem c "({[_" then True else False

    return (b,mid,post)
  return $ case m of
    Nothing -> S pre
    Just (b,mid,post) -> case b of
      True  -> I (S pre) (b,mid) (post)
      False -> I (S pre) (b,mid) (post)

parseLine :: SourceName -> String -> TupleLine
parseLine src s = case runParser lineP () "" s of
  Right xx -> xx
  Left err -> error ("preprocessor parse error in file \"" ++ src ++ "\":\n" ++ show err)

convertTupleLine :: TupleLine -> String
convertTupleLine (S ln) = ln
convertTupleLine (I pre (b,mid) post) = pre' ++ mid'' ++ post' where
  pre'  = convertTupleLine pre
  mid'  = convertTupleLine mid
  post' = convertTupleLine post
  mid''  = if b 
    then '(' : toTupleS mid' ++ ")"
    else "{" ++ mid' ++ "}"
    
processLine :: SourceName -> String -> String    
processLine src = convertTupleLine . parseLine src
    
--------------------------------------------------------------------------------  

main :: IO ()
main = 
  do
    args <- getArgs
    case args of

      [] -> interact (f "stdin")
      [inp] -> do
        text <- readFile inp
        putStrLn $ f inp text
      [inp,out] -> do
        text <- readFile inp
        writeFile out $ f inp text
      [inp,cpp,out] -> do             -- ghc calls the preprocessor this way
        text <- readFile cpp
        let pptext = f cpp text
        writeFile out pptext

      _ -> do
        print args
        putStrLn $ unlines
          [ "usage:"
          , "  tpp <input.hs >output.hs"
          , "  tpp input.hs >output.hs"
          , "  tpp input.hs output.hs"
          , "  tpp dummy.hs input.hs output.hs"
          ]
      
  where
    f src text = processLine src text

--------------------------------------------------------------------------------