ixdopp-0.1: Main.hs

module Main (main) where

import System
import Data.Generics

import Language.Haskell.Preprocessor
import Language.Haskell.Preprocessor.Error (errorAt)

main :: IO ()
main  = do
  args <- getArgs
  transform extension args

extension, clet, llet :: Extension
ixdo                  :: [String] -> Extension

-- Our new syntax is the ixdo syntax along with the base syntax.
extension = clet `mappend` ixdo ["clet"] `mappend` base

-- Ixdo takes a list of extra "let"-like keywords that it should
-- transform in do-notation let style.
ixdo lets = mempty
  {
    -- One indentation-starting keyword
    keywords    = [[I "ixdo"]],
    transformer = everywhere (mkT trans)
  }
    where
  trans :: Ast -> Ast
  trans ast @Block { item = Token { val = "ixdo" } }
    -- <expr> ::= 'ixdo' VINDENT ( <stm> ';' )* <expr> VDEDENT
    = case splitSemis (body ast) of
        []   -> errorAt ast "ixdo must end with an expression"
        stms -> foldr stm (parens (last stms)) (init stms)
                `cloneLoc` ast
  trans ast = ast

  stm asts rest = case asts of
    [b @Block { item = t, next = Empty }]
      -- <stm> ::= 'let' <bindings>
      | val t `elem` ("let" : lets)
      -> parens [b { next = inast }, rest]
            where inast = Single newToken { tag = Other, val = "in" }
    _ -> parens $ case splitVal "<-" asts of
      -- <stm> ::= <expr>
      Nothing -> quasi "'#1' >>>= \\_ -> '#2'" [parens asts, rest]
      -- <stm> ::= <pat> <- <expr>
      Just (pat, _, expr)
              -> quasi "'#1' >>>= \\'#2' -> '#3'"
                       [parens expr, parens pat, rest]

clet = mempty
  {
    keywords    = [[I "clet", P "in"], [I "clet"]],
    transformer = everywhere (mkT trans)
  }
    where
  trans :: Ast -> Ast
  trans ast @Block { item = Token { val = "clet" } }
    = foldr stm Empty (splitSemis (body ast))
      `cloneLoc` ast
  trans ast = ast

  stm asts rest = noParens $ case splitVal "=" asts of
    Nothing -> errorAt asts "expected = in clet"
    Just (pat, _, expr)
            -> quasi "'#1' $ \\ '#2' -> '#3'"
                     [parens expr, parens pat, rest]

llet = mempty
  {
    keywords    = [[I "llet", P "in"], [I "llet"]],
    transformer = everywhere (mkT trans)
  }
    where
  trans :: Ast -> Ast
  trans ast @Block { item = Token { val = "llet" } }
    = foldr stm Empty (splitSemis (body ast))
      `cloneLoc` ast
  trans ast = ast

  stm asts rest = noParens $ case splitVal "=" asts of
    Nothing -> errorAt asts "expected = in llet"
    Just (pat, _, expr)
            -> case splitAllBy (valIs ",") pat of
      []   -> errorAt asts "llet binding expected"
      pats -> quasi "'#1' '#2' $ \\ '#3' -> '#4'"
                    [parens expr, types, parens args, rest] where
        types = noParens
                  [ typify v
                  | [Single Token { tag = Variable, val = v }] <- pats ]
        args  = debangifyList pat

  debangifyList pat = case splitBy (valIs ",") pat of
    Nothing        -> debangify pat
    Just (a, c, r) -> debangify a ++ c : debangify r

  debangify a @[(Single Token { tag = Variable })] = a
  debangify (Single Token { val = "!" } : a)       = a
  debangify a = errorAt a "strange llet pattern"

  typify ""     = parens []
  typify (c:cs) = parens (quasi ('L':c:" '#1'") [typify cs])