{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE RecordWildCards #-}
module Control.Arrow.QuasiQuoter
( proc
, procEx
) where
import Control.Arrow.Notation
import Data.List
import Language.Haskell.Exts as Exts hiding (Exp, Loc)
import Language.Haskell.Meta
import Language.Haskell.TH (Exp, Q, Loc(..), location )
import Language.Haskell.TH.Quote
import Text.Printf
proc :: QuasiQuoter
proc = procEx defaultParseMode{extensions = defaultExtensions}
procEx :: ParseMode -> QuasiQuoter
procEx parseMode = QuasiQuoter
{ quoteExp = quoteEx parseMode
, quotePat = error "proc: pattern quotes not supported"
, quoteType = error "proc: type quotes not supported"
, quoteDec = error "proc: dec quotes not supported"
}
quoteEx :: ParseMode -> String -> Q Exp
quoteEx mode inp =
case parseExpWithMode mode ("proc " ++ inp) of
ParseOk proc -> return $ toExp $ translateExp proc
ParseFailed loc err -> do
Loc{..} <- location
error $ printf "%s:%d:%d: %s" loc_filename
(fst loc_start + srcLine loc - 1)
(snd loc_start + srcColumn loc - 1)
err
defaultExtensions :: [Extension]
defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions
badExtensions :: [KnownExtension]
badExtensions =
[TransformListComp
,XmlSyntax, RegularPatterns
,UnboxedTuples
,QuasiQuotes
,DoRec, RecursiveDo
,TypeApplications
]