haskell-src-meta 0.2 → 0.3

raw patch · 15 files changed

+519/−711 lines, 15 filesdep ~basedep ~containersdep ~sybPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, containers, syb, template-haskell

API changes (from Hackage documentation)

Files

• examples/BF.hs +182/−0
• examples/Hs.hs +36/−0
• examples/HsHere.hs +114/−0
• examples/SKI.hs +155/−0
• haskell-src-meta.cabal +19/−20
• src/Language/Haskell/Meta/QQ/ADo.hs +0/−149
• src/Language/Haskell/Meta/QQ/BF.hs +0/−182
• src/Language/Haskell/Meta/QQ/Here.hs +0/−10
• src/Language/Haskell/Meta/QQ/Hs.hs +0/−34
• src/Language/Haskell/Meta/QQ/HsHere.hs +0/−114
• src/Language/Haskell/Meta/QQ/Idiom.hs +0/−44
• src/Language/Haskell/Meta/QQ/SKI.hs +0/−155
• src/Language/Haskell/Meta/Syntax/Translate.hs +8/−3
• src/Language/Haskell/Meta/Utils.hs +2/−0
• src/Language/Haskell/TH/Instances/Lift.hs +3/−0

@@ -0,0 +1,182 @@+{-# LANGUAGE BangPatterns, TemplateHaskell #-}++module Language.Haskell.Meta.QQ.BF (+   bf,bf2,bfHelloWorld+) where++import Language.Haskell.Meta (parsePat)+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++import Data.Char+import Data.IntMap(IntMap)+import qualified Data.IntMap as IM+++bf :: QuasiQuoter+bf = QuasiQuoter { quoteExp = bfExpQ, quotePat = bfPatQ }++bf2 :: QuasiQuoter+bf2 = QuasiQuoter { quoteExp = bf2ExpQ, quotePat = bfPatQ }++bf2ExpQ :: String -> ExpQ+bf2ExpQ s = [|eval (parse s)|]++bfExpQ :: String -> ExpQ+bfExpQ s = [|eval_ (parse s)|]++bfPatQ :: String -> PatQ+bfPatQ s = do+  let p = (parsePat+            . show+              . parse) s+  case p of+    Left e -> fail e+    Right p -> return p++instance Lift Bf where+  lift Inp = [|Inp|]+  lift Out = [|Out|]+  lift Inc = [|Inc|]+  lift Dec = [|Dec|]+  lift MovL = [|MovL|]+  lift MovR = [|MovR|]+  lift (While xs) = [|While $(lift xs)|]++type Ptr = Int+newtype Mem = Mem (IntMap Int) deriving (Show)++data Bf = Inp+        | Out+        | Inc+        | Dec+        | MovL+        | MovR+        | While [Bf]+  deriving (Eq,Ord,Read,Show)++data Status = D Ptr Mem+            | W Int Status+            | R (Int -> Status)++-- ghci> exec (parse helloWorld)+-- Hello World!+-- (4,Mem (fromList [(0,0),(1,87),(2,100),(3,33),(4,10)]))+bfHelloWorld :: String+bfHelloWorld = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>."++eval_ :: [Bf] -> (String -> String)+eval_ is = go (run 0 initMem is)+  where go (D p m)    _    = []+        go (W n s)    cs   = chr n : go s cs+        go (R cont)   []   = "*** Exception: bf blocked on input"+        go (R cont) (c:cs) = go ((cont . ord) c) cs++eval :: [Bf] -> String -> (String, (Ptr, Mem))+eval is = go [] (run 0 initMem is)+  where go acc (D p m)    _    = (reverse acc, (p, m))+        go acc (W n s)    cs   = go (chr n:acc) s cs+        go _   (R cont)   []   = ("*** Exception: bf blocked on input",(-1, Mem IM.empty))+        go acc (R cont) (c:cs) = go acc ((cont . ord) c) cs++exec :: [Bf] -> IO (Ptr, Mem)+exec is = go (run 0 initMem is)+  where go (D p m)  = return (p, m)+        go (W n s)  = putChar (chr n) >> go s+        go (R cont) = go . cont . ord =<< getChar++run :: Ptr -> Mem -> [Bf] -> Status+run dp m is = step dp m is (\dp m -> D dp m)++step :: Ptr -> Mem -> [Bf] -> (Ptr -> Mem -> Status) -> Status+step dp m   []          k = k dp m+step dp m (Inc:is)      k = step dp (inc dp m) is k+step dp m (Dec:is)      k = step dp (dec dp m) is k+step dp m (MovL:is)     k = step (dp-1) m is k+step dp m (MovR:is)     k = step (dp+1) m is k+step dp m (Inp:is)      k = R (\c -> step dp (wr m dp c) is k)+step dp m (Out:is)      k = W (rd m dp) (step dp m is k)+step dp m (While xs:is) k = let go dp m = if rd m dp == 0+                                            then step dp m is k+                                            else step dp m xs go+                            in go dp m++initMem :: Mem+initMem = Mem IM.empty++inc :: Ptr -> (Mem -> Mem)+dec :: Ptr -> (Mem -> Mem)+rd :: Mem -> Ptr -> Int+wr :: Mem -> Ptr -> Int -> Mem+upd :: Mem -> Ptr -> (Int -> Int) -> Mem+inc p m = upd m p (+1)+dec p m = upd m p (subtract 1)+rd (Mem m) p = maybe 0 id (IM.lookup p m)+wr (Mem m) p n = Mem (IM.insert p n m)+upd m p f = wr m p (f (rd m p))++parse :: String -> [Bf]+parse s = go 0 [] s (\_ xs _ -> xs)+  where go :: Int -> [Bf] -> String+          -> (Int -> [Bf] -> String -> o) -> o+        go !n acc   []     k = k n (reverse acc) []+        go !n acc (',':cs) k = go (n+1) (Inp:acc) cs k+        go !n acc ('.':cs) k = go (n+1) (Out:acc) cs k+        go !n acc ('+':cs) k = go (n+1) (Inc:acc) cs k+        go !n acc ('-':cs) k = go (n+1) (Dec:acc) cs k+        go !n acc ('<':cs) k = go (n+1) (MovL:acc) cs k+        go !n acc ('>':cs) k = go (n+1) (MovR:acc) cs k+        go !n acc ('[':cs) k = go (n+1) [] cs (\n xs cs ->+                                go n (While xs:acc) cs k)+        go !n acc (']':cs) k = k (n+1) (reverse acc) cs+        go !n acc (c  :cs) k = go n acc cs k++++test0 = do+  a <- readFile "prime.bf"+  return (parse a)++++++++{-+data Bf = Inp+        | Out+        | Inc+        | Dec+        | MovL+        | MovR+        | While [Bf]+        | Error String+  deriving (Eq,Ord,Read,Show)++parse :: String -> [Bf]+parse s = let p n s = case go n [] s of+                        (_,xs,[]) -> xs+                        (n,xs, s) -> xs ++ p n s+          in p 0 s+  where go :: Int -> [Bf] -> [Char] -> (Int, [Bf], String)+        go !n acc   []     = (n, reverse acc, [])+        go !n acc (',':cs) = go (n+1) (Inp:acc) cs+        go !n acc ('.':cs) = go (n+1) (Out:acc) cs+        go !n acc ('+':cs) = go (n+1) (Inc:acc) cs+        go !n acc ('-':cs) = go (n+1) (Dec:acc) cs+        go !n acc ('<':cs) = go (n+1) (MovL:acc) cs+        go !n acc ('>':cs) = go (n+1) (MovR:acc) cs+        go !n acc ('[':cs) = case go (n+1) [] cs of+                                (n,xs,cs) -> go n (While xs:acc) cs+        go !n acc (']':cs) = (n+1, reverse acc, cs)+        go !n acc (c  :cs) = (n+1, [Error ("go error: char "++show n+                                    ++" illegal character: "++show c)], [])+-}++++++

@@ -0,0 +1,36 @@+++-- | Eat your face!++module Language.Haskell.Meta.QQ.Hs (hs, pat) where++import Language.Haskell.Meta (parseExp, parsePat)+import Language.Haskell.Meta.Utils (pretty)+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++-- |+-- > ghci> [$hs|\x -> (x,x)|] 42+-- > (42,42)+-- > ghci> (\[$hs|a@(x,_)|] -> (a,x)) (42,88)+-- > ((42,88),42)+hs :: QuasiQuoter+hs = QuasiQuoter+      { quoteExp = either fail transformE . parseExp+      , quotePat = either fail transformP . parsePat+      }++transformE :: Exp -> ExpQ+transformE = return++transformP :: Pat -> PatQ+transformP = return++pat :: QuasiQuoter+pat = QuasiQuoter+        { quoteExp = quoteExp hs+        , quotePat = \s -> case parseExp s of+                Left err -> fail err+                Right e -> either fail return (parsePat . pretty $ e)+        }

@@ -0,0 +1,114 @@+{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-}++module Language.Haskell.Meta.QQ.HsHere (here) where++import Language.Haskell.Meta (parseExp, parsePat)+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Language.Haskell.Meta.Utils (cleanNames)+import Text.ParserCombinators.ReadP+import Data.Typeable(Typeable)+import Data.Generics(Data)++data Here+  = CodeH Exp+  | TextH String+  | ManyH [Here]+  deriving (Eq,Show,Data,Typeable)++-- | Example:+--+-- > a x = [$here| random "text" $(x + 1)+-- >  something else|]+--+-- Is like:+--+-- > a x = " random \"text\" "++ show (x + 1) ++"\n  something else"+here :: QuasiQuoter+here = QuasiQuoter+        {quoteExp = hereExpQ+        ,quotePat = herePatQ}++instance Lift Here+  where lift = liftHere++liftHere :: Here -> ExpQ+liftHere (TextH s)  = (litE . stringL) s+liftHere (CodeH e)  = [|show $(return e)|]+liftHere (ManyH hs) = [|concat $(listE (fmap liftHere hs))|]+++hereExpQ :: String -> ExpQ+hereExpQ s = case run s of+              [] -> fail "here: parse error"+              e:_ -> lift (cleanNames e)++herePatQ :: String -> PatQ+herePatQ s = do+  e <- hereExpQ s+  let p = (parsePat+            . pprint+              . cleanNames) e+  case p of+    Left e -> fail e+    Right p -> return p++run :: String -> [Here]+run = fst . parse++parse :: String -> ([Here], String)+parse = runP hereP++hereP :: ReadP Here+hereP = (ManyH . mergeTexts)+  `fmap` many (oneP =<< look)++mergeTexts :: [Here] -> [Here]+mergeTexts [] = []+mergeTexts (TextH s:TextH t:hs)+  = mergeTexts (TextH (s++t):hs)+mergeTexts (h:hs) = h : mergeTexts hs++oneP :: String -> ReadP Here+oneP s+  | [] <- s         = pfail+  | '\\':'$':s <- s = do skip 2+                         (TextH . ("\\$"++))+                          `fmap` munch (/='\\')+  | '$':'(':s <- s  = skip 2 >> go 1 [] s+  | c:s <- s        = do skip 1+                         (TextH . (c:))+                          `fmap` munch (not.(`elem`"\\$"))+  where go _ acc  []         = return (TextH (reverse acc))+        go 1 []  (')':_) = skip 1 >> return (TextH "$()")+        go 1 acc (')':_) = do skip (1 + length acc)+                              let s = reverse acc+                              either (const (return+                                              (TextH s)))+                                     (return . CodeH)+                                     (parseExp s)+        go n acc ('(':s)     = go (n+1) ('(':acc) s+        go n acc (')':s)     = go (n-1) (')':acc) s+        go n acc (c:s)       = go n (c:acc) s+++runP :: ReadP a -> String -> ([a], String)+runP p s = case readP_to_S p s of+              [] -> ([],[])+              xs -> mapfst (:[]) (last xs)+  where mapfst f (a,b) = (f a,b)+skip :: Int -> ReadP ()+skip n = count n get >> return ()+lexemeP :: ReadP a -> ReadP a+lexemeP p = p >>= \x -> skipSpaces >> return x+nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)+nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)+parensP  = between oparenP cparenP+bracksP  = between oparenP cparenP+oparenP  = char '('+cparenP  = char ')'+obrackP  = char '['+cbrackP  = char ']'+

@@ -0,0 +1,155 @@+{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-}++module Language.Haskell.Meta.QQ.SKI (SKI(..),ski) where++import Language.Haskell.Meta (parseExp, parsePat)+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unQ)+import Text.ParserCombinators.ReadP+import Data.Typeable(Typeable)+import Data.Generics(Data)+import Text.PrettyPrint(render)++data SKI = S | K | I | E Exp | SKI :$ SKI+  deriving (Eq,Data,Typeable)++run :: String -> [SKI]+run = fmap eval . fst . parse++-- I x = x+-- K x y = x+-- S x y z = (x z) (y z)+eval :: SKI -> SKI+eval (I :$ x)               = eval x+eval ((K :$ x) :$ y)        = eval x+eval (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))+eval (E e :$ E e')          = E (unQ[|$(return e) $(return e')|])+eval (x :$ y)               = eval0 ((eval x) :$ (eval y))+eval  x                     = x+eval0 (I :$ x)               = eval x+eval0 ((K :$ x) :$ y)        = eval x+eval0 (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))+eval0 (E e :$ E e')          = E (unQ[|$(return e) $(return e')|])+eval0  x                     = x++ski :: QuasiQuoter+ski = QuasiQuoter+        {quoteExp = skiExpQ+        ,quotePat = skiPatQ}++instance Lift SKI where+  lift = liftSKI++liftSKI (E e) = return e+liftSKI a     = go a+  where go S = [|S|]+        go K = [|K|]+        go I = [|I|]+        go (E e) = [|E e|]+        go (x:$y) = [|$(go x) :$ $(go y)|]++instance Show SKI where+        showsPrec p (S) = showString "S"+        showsPrec p (K) = showString "K"+        showsPrec p (I) = showString "I"+        showsPrec p (E x1)+          = showParen (p > 10)+              (showString (render (ppDoc x1)))+        showsPrec p ((:$) x1 x2)+          = showParen (p > 10)+              (showsPrec 11 x1 . (showString " :$ " . showsPrec 10 x2))++skiExpQ :: String -> ExpQ+skiExpQ s = case run s of+              [] -> fail "ski: parse error"+              e:_ -> lift (cleanNames e)++skiPatQ :: String -> PatQ+skiPatQ s = do+  e <- skiExpQ s+  let p = (parsePat+            . pprint+              . cleanNames) e+  case p of+    Left e -> fail e+    Right p -> return p++-- ghci> parse "S(SS)IK(SK)"+-- ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"")+parse :: String -> ([SKI], String)+parse = runP skiP++skiP :: ReadP SKI+skiP = nestedP parensP+  (let go a = (do b <- lexemeP (oneP <++ skiP)+                  go (a:$b)) <++ return a+    in lexemeP (go =<< lexemeP oneP))++oneP :: ReadP SKI+oneP = nestedP parensP+  (lexemeP (choice [sP+                   ,kP+                   ,iP+                   ,spliceP =<< look+                   ]))++spliceP :: String -> ReadP SKI+spliceP s+  | '[':s <- s = skip 1 >> go 1 [] s+  | otherwise  = pfail+  where go _ _   []         = pfail+        go 1 acc (']':_) = do skip (1 + length acc)+                              either (const pfail)+                                     (return . E)+                                     (parseExp (reverse acc))+        go n acc ('[':s)     = go (n+1) ('[':acc) s+        go n acc (']':s)     = go (n-1) (']':acc) s+        go n acc (c:s)       = go n (c:acc) s++++sP = (char 's' +++ char 'S') >> return S+kP = (char 'k' +++ char 'K') >> return K+iP = (char 'i' +++ char 'I') >> return I++runP :: ReadP a -> String -> ([a], String)+runP p s = case readP_to_S p s of+              [] -> ([],[])+              xs -> mapfst (:[]) (last xs)+  where mapfst f (a,b) = (f a,b)+skip :: Int -> ReadP ()+skip n = count n get >> return ()+lexemeP :: ReadP a -> ReadP a+lexemeP p = p >>= \x -> skipSpaces >> return x+nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)+nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)+parensP  = between oparenP cparenP+bracksP  = between oparenP cparenP+oparenP  = char '('+cparenP  = char ')'+obrackP  = char '['+cbrackP  = char ']'+++++{-+import Prelude hiding (($))+data Komb = S (Maybe (Komb, Maybe Komb)) | K (Maybe Komb) deriving Show+S Nothing $ x = S (Just (x, Nothing))+S (Just (x, Nothing)) $ y = S (Just (x, Just y))+S (Just (x, Just y)) $ z = x $ z $ (y $ z)+K Nothing $ x = K (Just x)+K (Just x) $ y = y+q x = x $ (c $ k) $ k $ k $ s+ where s = S Nothing+       k = K Nothing+       c = s $ (b $ b $ s) $ k $ k+       b = s $ (k $ s) $ k+-}+++

@@ -1,5 +1,5 @@ name:               haskell-src-meta-version:            0.2+version:            0.3 cabal-version:      >= 1.6 build-type:         Simple license:            BSD3@@ -8,31 +8,30 @@ author:             Matt Morrow copyright:          (c) Matt Morrow maintainer:         Ben Millwood <haskell@benmachine.co.uk>+bug-reports:        https://github.com/benmachine/haskell-src-meta/issues stability:          experimental synopsis:           Parse source to template-haskell abstract syntax. description:        The translation from haskell-src-exts abstract syntax                     to template-haskell abstract syntax isn't 100% complete yet. +extra-source-files: examples/*.hs+ library-  build-depends:      base >= 4.1 && < 4.3, containers >= 0.2 && < 0.4,-                      haskell-src-exts >= 1.6 && < 1.10,-                      template-haskell >= 2.3 && < 2.5,-                      pretty == 1.0.*, syb >= 0.1 && < 0.2, th-lift == 0.5.*-  hs-source-dirs:     src-  exposed-modules:    Language.Haskell.Meta,-                      Language.Haskell.Meta.Parse,-                      Language.Haskell.Meta.Syntax,-                      Language.Haskell.Meta.Syntax.Vars,-                      Language.Haskell.Meta.Syntax.Translate,-                      Language.Haskell.TH.Instances.Lift,-                      Language.Haskell.Meta.Utils,-                      Language.Haskell.Meta.QQ.ADo,-                      Language.Haskell.Meta.QQ.Hs,-                      Language.Haskell.Meta.QQ.Here,-                      Language.Haskell.Meta.QQ.HsHere,-                      Language.Haskell.Meta.QQ.Idiom,-                      Language.Haskell.Meta.QQ.BF,-                      Language.Haskell.Meta.QQ.SKI+  build-depends:   base >= 4.1 && < 4.4,+                   containers >= 0.2 && < 0.5,+                   haskell-src-exts >= 1.6 && < 1.10,+                   template-haskell >= 2.3 && < 2.6,+                   pretty == 1.0.*,+                   syb >= 0.1 && < 0.3,+                   th-lift == 0.5.*+  hs-source-dirs:  src+  exposed-modules: Language.Haskell.Meta+                   Language.Haskell.Meta.Parse+                   Language.Haskell.Meta.Syntax+                   Language.Haskell.Meta.Syntax.Vars+                   Language.Haskell.Meta.Syntax.Translate+                   Language.Haskell.TH.Instances.Lift+                   Language.Haskell.Meta.Utils  source-repository head   type:     git

@@ -1,149 +0,0 @@-{-# LANGUAGE PatternGuards, TemplateHaskell, QuasiQuotes #-}---- | Applicative do. Phillipa Cowderoy's idea, some explanations due Edward--- Kmett------ Pointful version of "Language.Haskell.Meta.QQ.Idiom". Note the only--- expression which has the bound variables in scope is the last one.------ This lets you work with applicatives without the order of fields in an data--- constructor becoming such a burden.------ In a similar role as 'fail' in do notation, if match failures can be--- expected, the result is an @Applicative f => f (Maybe a)@, rather than--- @Applicative f => f a@, where @a@ may be partially defined.-module Language.Haskell.Meta.QQ.ADo (--    ado,-    ado'--    -- * Desugaring-    -- $desugaring-    ) where--import Control.Applicative-import Language.Haskell.Meta-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Control.Monad-import qualified Data.Set as S--import Language.Haskell.Meta.Utils (cleanNames)--import Data.Generics---- $desugaring------ If you use patterns that may fail:------ > foo :: Applicative f => f (Maybe T)--- > foo = [$ado|--- >    x:xs <- foo bar baz--- >    Just y <- quux quaffle--- >    T x y |]------ 'ado' desugars to:------ > foo = (\x y -> case (x,y) of--- >                    (x:xs,Just y) -> Just $ T x y--- >                    _ -> Nothing--- >        ) <$> foo bar baz <*> quux quaffle------ While 'ado'' desugars to the less safe:------ > foo = (\(x:xs) (Just y) -> T x y) <$> foo bar baz <*> quux quaffle------ If the simple patterns cannot fail, there is no 'Maybe' for the 'ado' quote,--- just like 'ado'':------ > newtype A = A Int--- > foo :: Applicative f => f T--- > foo = [$ado|--- >    ~(x:xs) <- foo bar baz--- >    A y <- quux quaffle--- >    T x y |]------ Becomes:------ > foo = (\ ~(x:xs) (A y) -> T x y) <$> foo bar baz <*> quux quaffle---- | Usage:------ > ghci> [$ado| a <- "foo"; b <- "bar"; (a,b) |]--- > [('f','b'),('f','a'),('f','r'),('o','b'),('o','a'),('o','r'),('o','b'),('o','a'),('o','r')]------ > ghci> [$ado| Just a <- [Just 1,Nothing,Just 2]; b <- "fo"; (a,b) |]--- > [Just (1,'f'),Just (1,'o'),Nothing,Nothing,Just (2,'f'),Just (2,'o')]-ado :: QuasiQuoter-ado = ado'' False---- | Variant of 'ado' that does not implicitly add a Maybe when patterns may fail:------ > ghci> [$ado'| Just a <- [Just 1,Nothing,Just 2]; b <- "fo"; (a,b) |]--- > [(1,'f'),(1,'o'),*** Exception: <interactive>:...----ado' :: QuasiQuoter-ado' = ado'' True--ado'' ::  Bool -> QuasiQuoter-ado'' b = QuasiQuoter-    (\str -> fmap cleanNames $ applicate b =<< parseDo str)-    (either fail return . parsePat)--parseDo ::  (Monad m) => String -> m [Stmt]-parseDo str =-    let prefix = "do\n" in-    case parseExp $ prefix ++ str of-      Right (DoE stmts) -> return stmts-      Right a -> fail $ "ado can't handle:\n" ++ show a-      Left a -> fail a--applicate :: Bool -> [Stmt] -> ExpQ-applicate rawPatterns stmt = do-    (_:ps,f:es) <- fmap (unzip . reverse) $-            flip mapM stmt $ \s ->-            case s of-                BindS p e -> return (p,e)-                NoBindS e   -> return (WildP,e)-                LetS _ -> fail $ "LetS not supported"-                ParS _ -> fail $ "ParS not supported"--    fps <- failingPatterns ps-    f' <- case filter (not . snd) $ zip ps fps of-        [] -> return $ LamE ps f-        _ | rawPatterns -> return $ LamE ps f-          | otherwise -> do-            xs <- mapM (const $ newName "x") ps-            return $ LamE (map VarP xs) $ CaseE (TupE (map VarE xs))-                [Match (TupP ps) (NormalB $ ConE 'Just `AppE` f) []-                ,Match WildP (NormalB $ ConE 'Nothing) []-                ]--    return $ foldl (\g e -> VarE '(<**>) `AppE` e `AppE` g)-                    (VarE 'pure `AppE` f')-                    es--failingPatterns ::  (Data a) => [a] -> Q [Bool]-failingPatterns ps = flip mapM ps $ \p ->-    let couldFail x = liftM not (singleCon x)--        constrs :: Data a => a -> S.Set Name-        constrs = S.fromList . map (\(ConP n _) -> n)-            . listify (\x -> case x of ConP {} -> True; _ -> False)-        irrefutables = constrs-                    . listify (\x -> case x of TildeP {} -> True; _ -> False)--    in liftM null $ filterM couldFail $ S.elems $-        constrs p S.\\ irrefutables p--singleCon ::  Name -> Q Bool-singleCon n = do-    DataConI _ _ tn _ <- reify n-    TyConI dec <- reify tn-    case dec of-        DataD _ _ _ [_] _ -> return True-        NewtypeD {} -> return True-        DataD _ _ _ (_:_) _ -> return False-        _ -> fail $ "Bad dec: "++show dec-

@@ -1,182 +0,0 @@-{-# LANGUAGE BangPatterns, TemplateHaskell #-}--module Language.Haskell.Meta.QQ.BF (-   bf,bf2,bfHelloWorld-) where--import Language.Haskell.Meta-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax--import Data.Char-import Data.IntMap(IntMap)-import qualified Data.IntMap as IM---bf :: QuasiQuoter-bf = QuasiQuoter bfExpQ bfPatQ--bf2 :: QuasiQuoter-bf2 = QuasiQuoter bf2ExpQ bfPatQ--bf2ExpQ :: String -> ExpQ-bf2ExpQ s = [|eval (parse s)|]--bfExpQ :: String -> ExpQ-bfExpQ s = [|eval_ (parse s)|]--bfPatQ :: String -> PatQ-bfPatQ s = do-  let p = (parsePat-            . show-              . parse) s-  case p of-    Left e -> fail e-    Right p -> return p--instance Lift Bf where-  lift Inp = [|Inp|]-  lift Out = [|Out|]-  lift Inc = [|Inc|]-  lift Dec = [|Dec|]-  lift MovL = [|MovL|]-  lift MovR = [|MovR|]-  lift (While xs) = [|While $(lift xs)|]--type Ptr = Int-newtype Mem = Mem (IntMap Int) deriving (Show)--data Bf = Inp-        | Out-        | Inc-        | Dec-        | MovL-        | MovR-        | While [Bf]-  deriving (Eq,Ord,Read,Show)--data Status = D Ptr Mem-            | W Int Status-            | R (Int -> Status)---- ghci> exec (parse helloWorld)--- Hello World!--- (4,Mem (fromList [(0,0),(1,87),(2,100),(3,33),(4,10)]))-bfHelloWorld :: String-bfHelloWorld = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>."--eval_ :: [Bf] -> (String -> String)-eval_ is = go (run 0 initMem is)-  where go (D p m)    _    = []-        go (W n s)    cs   = chr n : go s cs-        go (R cont)   []   = "*** Exception: bf blocked on input"-        go (R cont) (c:cs) = go ((cont . ord) c) cs--eval :: [Bf] -> String -> (String, (Ptr, Mem))-eval is = go [] (run 0 initMem is)-  where go acc (D p m)    _    = (reverse acc, (p, m))-        go acc (W n s)    cs   = go (chr n:acc) s cs-        go _   (R cont)   []   = ("*** Exception: bf blocked on input",(-1, Mem IM.empty))-        go acc (R cont) (c:cs) = go acc ((cont . ord) c) cs--exec :: [Bf] -> IO (Ptr, Mem)-exec is = go (run 0 initMem is)-  where go (D p m)  = return (p, m)-        go (W n s)  = putChar (chr n) >> go s-        go (R cont) = go . cont . ord =<< getChar--run :: Ptr -> Mem -> [Bf] -> Status-run dp m is = step dp m is (\dp m -> D dp m)--step :: Ptr -> Mem -> [Bf] -> (Ptr -> Mem -> Status) -> Status-step dp m   []          k = k dp m-step dp m (Inc:is)      k = step dp (inc dp m) is k-step dp m (Dec:is)      k = step dp (dec dp m) is k-step dp m (MovL:is)     k = step (dp-1) m is k-step dp m (MovR:is)     k = step (dp+1) m is k-step dp m (Inp:is)      k = R (\c -> step dp (wr m dp c) is k)-step dp m (Out:is)      k = W (rd m dp) (step dp m is k)-step dp m (While xs:is) k = let go dp m = if rd m dp == 0-                                            then step dp m is k-                                            else step dp m xs go-                            in go dp m--initMem :: Mem-initMem = Mem IM.empty--inc :: Ptr -> (Mem -> Mem)-dec :: Ptr -> (Mem -> Mem)-rd :: Mem -> Ptr -> Int-wr :: Mem -> Ptr -> Int -> Mem-upd :: Mem -> Ptr -> (Int -> Int) -> Mem-inc p m = upd m p (+1)-dec p m = upd m p (subtract 1)-rd (Mem m) p = maybe 0 id (IM.lookup p m)-wr (Mem m) p n = Mem (IM.insert p n m)-upd m p f = wr m p (f (rd m p))--parse :: String -> [Bf]-parse s = go 0 [] s (\_ xs _ -> xs)-  where go :: Int -> [Bf] -> String-          -> (Int -> [Bf] -> String -> o) -> o-        go !n acc   []     k = k n (reverse acc) []-        go !n acc (',':cs) k = go (n+1) (Inp:acc) cs k-        go !n acc ('.':cs) k = go (n+1) (Out:acc) cs k-        go !n acc ('+':cs) k = go (n+1) (Inc:acc) cs k-        go !n acc ('-':cs) k = go (n+1) (Dec:acc) cs k-        go !n acc ('<':cs) k = go (n+1) (MovL:acc) cs k-        go !n acc ('>':cs) k = go (n+1) (MovR:acc) cs k-        go !n acc ('[':cs) k = go (n+1) [] cs (\n xs cs ->-                                go n (While xs:acc) cs k)-        go !n acc (']':cs) k = k (n+1) (reverse acc) cs-        go !n acc (c  :cs) k = go n acc cs k----test0 = do-  a <- readFile "prime.bf"-  return (parse a)--------{--data Bf = Inp-        | Out-        | Inc-        | Dec-        | MovL-        | MovR-        | While [Bf]-        | Error String-  deriving (Eq,Ord,Read,Show)--parse :: String -> [Bf]-parse s = let p n s = case go n [] s of-                        (_,xs,[]) -> xs-                        (n,xs, s) -> xs ++ p n s-          in p 0 s-  where go :: Int -> [Bf] -> [Char] -> (Int, [Bf], String)-        go !n acc   []     = (n, reverse acc, [])-        go !n acc (',':cs) = go (n+1) (Inp:acc) cs-        go !n acc ('.':cs) = go (n+1) (Out:acc) cs-        go !n acc ('+':cs) = go (n+1) (Inc:acc) cs-        go !n acc ('-':cs) = go (n+1) (Dec:acc) cs-        go !n acc ('<':cs) = go (n+1) (MovL:acc) cs-        go !n acc ('>':cs) = go (n+1) (MovR:acc) cs-        go !n acc ('[':cs) = case go (n+1) [] cs of-                                (n,xs,cs) -> go n (While xs:acc) cs-        go !n acc (']':cs) = (n+1, reverse acc, cs)-        go !n acc (c  :cs) = (n+1, [Error ("go error: char "++show n-                                    ++" illegal character: "++show c)], [])--}------

@@ -1,10 +0,0 @@---- | Here!--module Language.Haskell.Meta.QQ.Here (here) where--import Language.Haskell.TH.Quote-import Language.Haskell.TH.Lib--here :: QuasiQuoter-here = QuasiQuoter (litE . stringL) (litP . stringL)

@@ -1,34 +0,0 @@----- | Eat your face!--module Language.Haskell.Meta.QQ.Hs (hs, pat) where--import Language.Haskell.Meta-import Language.Haskell.Meta.Utils-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax---- |--- > ghci> [$hs|\x -> (x,x)|] 42--- > (42,42)--- > ghci> (\[$hs|a@(x,_)|] -> (a,x)) (42,88)--- > ((42,88),42)-hs :: QuasiQuoter-hs = QuasiQuoter-      (either fail transformE . parseExp)-      (either fail transformP . parsePat)--transformE :: Exp -> ExpQ-transformE = return--transformP :: Pat -> PatQ-transformP = return--pat :: QuasiQuoter-pat = QuasiQuoter-        (quoteExp hs)-        (\s -> case parseExp s of-                Left err -> fail err-                Right e -> either fail return (parsePat . pretty $ e))

@@ -1,114 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-}--module Language.Haskell.Meta.QQ.HsHere (here) where--import Language.Haskell.Meta-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Language.Haskell.Meta.Utils-import Text.ParserCombinators.ReadP-import Data.Typeable(Typeable)-import Data.Generics(Data)--data Here-  = CodeH Exp-  | TextH String-  | ManyH [Here]-  deriving (Eq,Show,Data,Typeable)---- | Example:------ > a x = [$here| random "text" $(x + 1)--- >  something else|]------ Is like:------ > a x = " random \"text\" "++ show (x + 1) ++"\n  something else"-here :: QuasiQuoter-here = QuasiQuoter-        {quoteExp = hereExpQ-        ,quotePat = herePatQ}--instance Lift Here-  where lift = liftHere--liftHere :: Here -> ExpQ-liftHere (TextH s)  = (litE . stringL) s-liftHere (CodeH e)  = [|show $(return e)|]-liftHere (ManyH hs) = [|concat $(listE (fmap liftHere hs))|]---hereExpQ :: String -> ExpQ-hereExpQ s = case run s of-              [] -> fail "here: parse error"-              e:_ -> lift (cleanNames e)--herePatQ :: String -> PatQ-herePatQ s = do-  e <- hereExpQ s-  let p = (parsePat-            . pprint-              . cleanNames) e-  case p of-    Left e -> fail e-    Right p -> return p--run :: String -> [Here]-run = fst . parse--parse :: String -> ([Here], String)-parse = runP hereP--hereP :: ReadP Here-hereP = (ManyH . mergeTexts)-  `fmap` many (oneP =<< look)--mergeTexts :: [Here] -> [Here]-mergeTexts [] = []-mergeTexts (TextH s:TextH t:hs)-  = mergeTexts (TextH (s++t):hs)-mergeTexts (h:hs) = h : mergeTexts hs--oneP :: String -> ReadP Here-oneP s-  | [] <- s         = pfail-  | '\\':'$':s <- s = do skip 2-                         (TextH . ("\\$"++))-                          `fmap` munch (/='\\')-  | '$':'(':s <- s  = skip 2 >> go 1 [] s-  | c:s <- s        = do skip 1-                         (TextH . (c:))-                          `fmap` munch (not.(`elem`"\\$"))-  where go _ acc  []         = return (TextH (reverse acc))-        go 1 []  (')':_) = skip 1 >> return (TextH "$()")-        go 1 acc (')':_) = do skip (1 + length acc)-                              let s = reverse acc-                              either (const (return-                                              (TextH s)))-                                     (return . CodeH)-                                     (parseExp s)-        go n acc ('(':s)     = go (n+1) ('(':acc) s-        go n acc (')':s)     = go (n-1) (')':acc) s-        go n acc (c:s)       = go n (c:acc) s---runP :: ReadP a -> String -> ([a], String)-runP p s = case readP_to_S p s of-              [] -> ([],[])-              xs -> mapfst (:[]) (last xs)-  where mapfst f (a,b) = (f a,b)-skip :: Int -> ReadP ()-skip n = count n get >> return ()-lexemeP :: ReadP a -> ReadP a-lexemeP p = p >>= \x -> skipSpaces >> return x-nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)-nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)-parensP  = between oparenP cparenP-bracksP  = between oparenP cparenP-oparenP  = char '('-cparenP  = char ')'-obrackP  = char '['-cbrackP  = char ']'-

@@ -1,44 +0,0 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}---- | Idiom brackets. Vixey's idea.--module Language.Haskell.Meta.QQ.Idiom (i) where--import Data.Generics-  (Data,everywhere,mkT)-import Control.Applicative-import Language.Haskell.Meta-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax---- ghci> [$i| (,) "foo" "bar" |]--- [('f','b'),('f','a'),('f','r'),('o','b'),('o','a'),('o','r'),('o','b'),('o','a'),('o','r')]-i :: QuasiQuoter-i = QuasiQuoter ((cleanNames <$>) . applicateQ)-        (either fail return . parsePat)--applicateQ :: String -> ExpQ-applicateQ s = case either fail unwindE (parseExp s) of-                  x:y:xs -> foldl-                              (\e e' -> [|$e <*> $e'|])-                              [|$(return x) <$> $(return y)|]-                              (fmap return xs)-                  _ -> fail "applicateQ fails."--unwindE :: Exp -> [Exp]-unwindE = go []-  where go acc (e `AppE` e') = go (e':acc) e-        go acc e = e:acc--cleanNames :: (Data a) => a -> a-cleanNames = everywhere (mkT cleanName)-  where cleanName :: Name -> Name-        cleanName n-          | isNameU n = n-          | otherwise = (mkName . nameBase) n-        isNameU :: Name -> Bool-        isNameU (Name _ (NameU _)) = True-        isNameU _ = False--

@@ -1,155 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-}--module Language.Haskell.Meta.QQ.SKI (SKI(..),ski) where--import Language.Haskell.Meta-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Language.Haskell.Meta.Utils-import Text.ParserCombinators.ReadP-import Data.Typeable(Typeable)-import Data.Generics(Data)-import Text.PrettyPrint(render)--data SKI = S | K | I | E Exp | SKI :$ SKI-  deriving (Eq,Data,Typeable)--run :: String -> [SKI]-run = fmap eval . fst . parse---- I x = x--- K x y = x--- S x y z = (x z) (y z)-eval :: SKI -> SKI-eval (I :$ x)               = eval x-eval ((K :$ x) :$ y)        = eval x-eval (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))-eval (E e :$ E e')          = E (unQ[|$(return e) $(return e')|])-eval (x :$ y)               = eval0 ((eval x) :$ (eval y))-eval  x                     = x-eval0 (I :$ x)               = eval x-eval0 ((K :$ x) :$ y)        = eval x-eval0 (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))-eval0 (E e :$ E e')          = E (unQ[|$(return e) $(return e')|])-eval0  x                     = x--ski :: QuasiQuoter-ski = QuasiQuoter-        {quoteExp = skiExpQ-        ,quotePat = skiPatQ}--instance Lift SKI where-  lift = liftSKI--liftSKI (E e) = return e-liftSKI a     = go a-  where go S = [|S|]-        go K = [|K|]-        go I = [|I|]-        go (E e) = [|E e|]-        go (x:$y) = [|$(go x) :$ $(go y)|]--instance Show SKI where-        showsPrec p (S) = showString "S"-        showsPrec p (K) = showString "K"-        showsPrec p (I) = showString "I"-        showsPrec p (E x1)-          = showParen (p > 10)-              (showString (render (ppDoc x1)))-        showsPrec p ((:$) x1 x2)-          = showParen (p > 10)-              (showsPrec 11 x1 . (showString " :$ " . showsPrec 10 x2))--skiExpQ :: String -> ExpQ-skiExpQ s = case run s of-              [] -> fail "ski: parse error"-              e:_ -> lift (cleanNames e)--skiPatQ :: String -> PatQ-skiPatQ s = do-  e <- skiExpQ s-  let p = (parsePat-            . pprint-              . cleanNames) e-  case p of-    Left e -> fail e-    Right p -> return p---- ghci> parse "S(SS)IK(SK)"--- ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"")-parse :: String -> ([SKI], String)-parse = runP skiP--skiP :: ReadP SKI-skiP = nestedP parensP-  (let go a = (do b <- lexemeP (oneP <++ skiP)-                  go (a:$b)) <++ return a-    in lexemeP (go =<< lexemeP oneP))--oneP :: ReadP SKI-oneP = nestedP parensP-  (lexemeP (choice [sP-                   ,kP-                   ,iP-                   ,spliceP =<< look-                   ]))--spliceP :: String -> ReadP SKI-spliceP s-  | '[':s <- s = skip 1 >> go 1 [] s-  | otherwise  = pfail-  where go _ _   []         = pfail-        go 1 acc (']':_) = do skip (1 + length acc)-                              either (const pfail)-                                     (return . E)-                                     (parseExp (reverse acc))-        go n acc ('[':s)     = go (n+1) ('[':acc) s-        go n acc (']':s)     = go (n-1) (']':acc) s-        go n acc (c:s)       = go n (c:acc) s----sP = (char 's' +++ char 'S') >> return S-kP = (char 'k' +++ char 'K') >> return K-iP = (char 'i' +++ char 'I') >> return I--runP :: ReadP a -> String -> ([a], String)-runP p s = case readP_to_S p s of-              [] -> ([],[])-              xs -> mapfst (:[]) (last xs)-  where mapfst f (a,b) = (f a,b)-skip :: Int -> ReadP ()-skip n = count n get >> return ()-lexemeP :: ReadP a -> ReadP a-lexemeP p = p >>= \x -> skipSpaces >> return x-nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)-nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)-parensP  = between oparenP cparenP-bracksP  = between oparenP cparenP-oparenP  = char '('-cparenP  = char ')'-obrackP  = char '['-cbrackP  = char ']'-----{--import Prelude hiding (($))-data Komb = S (Maybe (Komb, Maybe Komb)) | K (Maybe Komb) deriving Show-S Nothing $ x = S (Just (x, Nothing))-S (Just (x, Nothing)) $ y = S (Just (x, Just y))-S (Just (x, Just y)) $ z = x $ z $ (y $ z)-K Nothing $ x = K (Just x)-K (Just x) $ y = y-q x = x $ (c $ k) $ k $ k $ s- where s = S Nothing-       k = K Nothing-       c = s $ (b $ b $ s) $ k $ k-       b = s $ (k $ s) $ k--}---

@@ -497,8 +497,10 @@     = let xs = fmap (flip SigD (toType t) . toName) ns       in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!" #if MIN_VERSION_template_haskell(2,4,0)-  toDec (Hs.InlineSig _ b act id) = PragmaD $ -    InlineP (toName id) (InlineSpec True False Nothing)+  toDec (Hs.InlineConlikeSig _ act id)                 = PragmaD $ +    InlineP (toName id) (InlineSpec True True $ transAct act)+  toDec (Hs.InlineSig _ b act id)                      = PragmaD $ +    InlineP (toName id) (InlineSpec b False $ transAct act) #endif /* MIN_VERSION_template_haskell(2,4,0) */  {- data HsDecl = ... | HsFunBind [HsMatch] | ...@@ -524,7 +526,10 @@ -- data Hs.Decl = ... | Hs.SpliceDecl Hs.SrcLoc Hs.Splice | ... -- data Hs.Splice = Hs.IdSplice String | Hs.ParenSplice Hs.Exp -+transAct act = case act of+  Hs.AlwaysActive    -> Nothing+  Hs.ActiveFrom n    -> Just (True,n)+  Hs.ActiveUntil n   -> Just (False,n)   

@@ -354,6 +354,7 @@ --  functions you wish to use for parsing in pattern and --  expression context respectively, put them inside --  a @Quoter@ datatype and pass this to quasify.+{- data Quoter a = Quoter   { expQ :: (Lift a) => String -> Q a   , patQ :: (Show a) => String -> Q a }@@ -362,6 +363,7 @@ quasify q = QuasiQuoter               (toExpQ (expQ q))               (toPatQ (patQ q))+              -}  toExpQ :: (Lift a) => (String -> Q a) -> (String -> ExpQ) toExpQ parseQ = (lift =<<) . parseQ

@@ -81,6 +81,9 @@                  , ''Pragma                  , ''Pred                  , ''TyVarBndr+#if MIN_VERSION_template_haskell(2,5,0)+                 , ''ClassInstance+#endif /* MIN_VERSION_template_haskell(2,5,0) */ #endif /* MIN_VERSION_template_haskell(2,4,0) */                  ])