tup-functor-0.2: preprocessor/tpp.hs

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

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

import Data.Char
import Data.List (intersect)

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

import System.Environment

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

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

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

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

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

toTupleS :: Cfg -> String -> String
toTupleS cfg s = {- trace ("|"++s++"|") $ -} case parseExp (inparens s) of
  ParseOk e -> pp (toTupleE cfg 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 :: Cfg -> TupleLine -> String
convertTupleLine cfg (S ln) = ln
convertTupleLine cfg (I pre (b,mid) post) = pre' ++ mid'' ++ post' where
  pre'  = convertTupleLine cfg pre
  mid'  = convertTupleLine cfg mid
  post' = convertTupleLine cfg post
  mid''  = if b 
    then '(' : toTupleS cfg mid' ++ ")"
    else "{" ++ mid' ++ "}"
    
processLine :: Cfg -> SourceName -> String -> String    
processLine cfg src = convertTupleLine cfg . parseLine src
    
--------------------------------------------------------------------------------  

data Cfg = Cfg { _constructor :: String }

tupCfg = Cfg "Tup"
vecCfg = Cfg "vec"

vecOpts = [ "-v" , "--vec" ]
tupOpts = [ "-t" , "--tup" ] 
possibleOpts = vecOpts ++ tupOpts

main :: IO ()
main = 
  do
    args0 <- getArgs
    let opts = filter (\x ->      x `elem` possibleOpts ) args0
        args = filter (\x -> not (x `elem` possibleOpts)) args0
    let vecMode = not (null opts)
    let cfg | null opts                            = tupCfg    -- default is tup
            | not (null (intersect opts tupOpts))  = tupCfg
            | not (null (intersect opts vecOpts))  = vecCfg
            | True                                 = error "tuplepp: fatal error while parsing the options"

    case args of

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

      _ -> do
        print args
        putStrLn $ unlines
          [ "usage:"
          , "  tpp [options] <input.hs >output.hs"
          , "  tpp [options] input.hs >output.hs"
          , "  tpp [options] input.hs output.hs"
          , "  tpp [options] dummy.hs input.hs output.hs     -- this is for GHC"
          , "options:"
          , "  -t, --tup : generates (Tup3 105 106 106) expressions"
          , "  -v, --vec : generates (vec3 105 106 106) expressions"
          ]
      
  where
    f cfg src text = processLine cfg src text

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