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

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

constructor :: String -> Exp
constructor con = Var $ UnQual $ Ident (con)

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

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

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 es -> foldl App (tupleCon (length es)) es
  _        -> App (tupleCon 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)
  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 deriving (Eq,Show)

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

tupOpts, vecOpts, possibleOpts :: [String]
tupOpts = [ "-t" , "--tup" ] 
vecOpts = [ "-v" , "--vec" ]
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:"
          , "  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"
          ]
      
  where
    f cfg src text = processLine cfg src text

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