tup-functor-0.3.0.0: 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 = (Cons a (Cons b (Cons c Empty)))
-- > x = (NTup3 (a,b,c))
-- 
-- This should also work in pattern context.
--

{-# 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)

--------------------------------------------------------------------------------
-- vec

-- | A string constructor (used for Cons and Empty)
constructor :: String -> Exp
constructor con = Var $ UnQual $ Ident (con)

toVecListE ::  Exp -> Exp
toVecListE e = 
  case e of
    Con (Special UnitCon) -> go []
    Tuple boxed es -> go es 
    _              -> go [e]
  where
    go [] = constructor "Empty"
    go (x:xs) = App (App (constructor "Cons") x) (go xs)

--------------------------------------------------------------------------------
-- tup

-- | The constructor Tup<K>
tupleCon :: Int -> Exp
tupleCon k = Var $ UnQual $ Ident ("Tup" ++ show k)

toTupleE :: Exp -> Exp
toTupleE e = case e of
  Con (Special UnitCon) -> tupleCon 0
  Tuple boxed es -> foldl App (tupleCon (length es)) es
  _              -> App (tupleCon 1) e

--------------------------------------------------------------------------------
-- ntup

-- | The constructor NTup<K>
ntupCon :: Int -> Exp
ntupCon k = Var $ UnQual $ Ident ("NTup" ++ show k)

toNewtypeE :: Exp -> Exp
toNewtypeE e = case e of
  Con (Special UnitCon) -> ntupCon 0
  Tuple boxed es -> App (ntupCon (length es)) e
  _              -> App (ntupCon 1) e

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

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

toTupleS :: Cfg -> String -> String
toTupleS cfg s = {- trace ("|"++s++"|") $ -} case parseExp (inparens s) of
  ParseOk e -> case cfg of
    TupPP  -> pp (toTupleE   e)
    VecPP  -> pp (toVecListE e)
    NTupPP -> pp (toNewtypeE e)
  err -> error ("tuplepp: parse error in tuple 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 ("tuplepp: 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 = TupPP | VecPP | NTupPP deriving (Eq,Show)

tupCfg, vecCfg, ntupCfg :: Cfg
tupCfg  = TupPP
vecCfg  = VecPP
ntupCfg = NTupPP

tupOpts, vecOpts, newtypeOpts, possibleOpts :: [String]
tupOpts      = [ "-t" , "--tup" ] 
vecOpts      = [ "-v" , "--vec" ]
newtypeOpts  = [ "-n" , "--ntup" , "--newtype" ]
possibleOpts = vecOpts ++ tupOpts ++ newtypeOpts

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
            | not (null (intersect opts newtypeOpts))  = ntupCfg
            | 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:"
          , "  tuplepp [options] <input.hs >output.hs"
          , "  tuplepp [options] input.hs >output.hs"
          , "  tuplepp [options] input.hs output.hs"
          , "  tuplepp [options] dummy.hs input.hs output.hs     -- this is for GHC"
          , "options:"
          , "  -t, --tup : generates (Tup3 105 106 107) expressions/patterns"
          , "  -v, --vec : generates (Cons 105 (Cons 106 (Cons 107 Empty))) expressions/patterns"
          , "  -n, --ntup, --newtype : generates (NTup3 (105,106,107)) expressions/patterns"
          ]
      
  where
    f cfg src text = processLine cfg src text

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