haskell-src-meta-0.8.0.1/0000755000000000000000000000000013113607060013175 5ustar0000000000000000haskell-src-meta-0.8.0.1/ChangeLog0000644000000000000000000000741713113607060014760 0ustar00000000000000000.8.0.1 - Bump base and template-haskell library to versions shipped with GHC 7.6. 0.8 - Compatibility with GHC 8.2. - Remove deprecated modules. 0.7.0.1 - Fixed a bug that caused deriving clauses to be ignored on TH 2.11. 0.7.0 - Compatibility with haskell-src-exts 1.18. - Support dropped for GHC < 7.6 and haskell-src-exts < 1.17. 0.6.0.14: - Compatibility with GHC 8.0. 0.6.0.13: - Compatibility with GHC HEAD, haskell-src-exts 1.17 - Remove hsBindsToDecs, since it was redundant with toDecs. Technically this requires a minor-version bump, but I doubt anyone was using it. 0.6.0.12: - Support th-orphans 0.13 0.6.0.11: - Support syb 0.6 0.6.0.10: - Support syb 0.5, th-orphans 0.12 0.6.0.9: - Compatibility with GHC 7.10 - Update th-orphans dependency - Drop GHC < 7.4 support (actually it was already broken, since HSE 1.16 requires base >= 4.5) 0.6.0.8: - Move to HSE 1.16 0.6.0.7: - Fix compilation oops 0.6.0.6: - Move to HSE 1.15, adding support for multiway if 0.6.0.5: - Update th-orphans dependency 0.6.0.4: - Drop support for GHC 6.12 - Move to HSE 1.14 0.6.0.3: - Update th-orphans dependency - Some dependency loosening in anticipation of GHC 7.8 0.6.0.2: - Update syb dependency 0.6.0.1: - Fix haddock parse error 0.6: - Cabal category Template Haskell - Partial support for list comprehensions - Support for type and data families and class decs - Split orphan instances into new package th-orphans - above changes courtesy of mgsloan - L.H.TH.Instances.Lift now deprecated - Removed L.H.M.Utils.deriveLiftPretty, dropped th-lift dependency - Rename L.H.M.Utils.unQ to unsafeRunQ - instance ToName Op - Support for unboxed tuple types and kind signatures - Compatibility with GHC 7.6.1, bringing support for kind variables and infix declarations 0.5.1.2: - More sensible determination of TH version available 0.5.1.1: - View pattern support, thanks to Nicolas Frisby. 0.5.1: - New module Language.Haskell.Meta.Parse.Careful, written by Reiner Pope so that ambiguous parses can be rejected instead of quietly done wrong. 0.5.0.3: - Support for GHC 7.4, thanks to Reiner Pope - Support for unresolved infix expressions, again thanks to Reiner Pope 0.5.0.2: - Fixed bug in translation of tuple constructors 0.5.0.1: - Added support for primitive string literals (Only in TH >= 2.5) 0.5: - Added support for instance declarations 0.4.0.2: - Compatibility with GHC 7.2 0.4.0.1: - Deprecate myDefaultParseMode and myDefaultExtensions in L.H.M.Parse 0.4: - Remove Language.Haskell.Meta.Syntax.Vars and the L.H.M.Syntax re-export module - Remove dependency on containers - Add support for let statements in (pattern) guards - Add support for negative patterns - Remove "support" for SpliceExps that didn't really make sense - Improve many error messages where things are unimplemented or impossible 0.3: - Fixes/additions to inline pragma support (Jonas Duregard) - Compatibility with GHC 7 and TH 2.5 - totalling three major versions! - Move some of the quasiquoters to their own package, and stop exporting the rest (they are kept as examples of usage) 0.2: - Compatibility with GHC 6.10 and TH 2.3 (Geoffrey Mainland) - Add support for do-blocks, pattern guards (Adam Vogt) - Add applicative-do quasiquoter (Adam Vogt) 0.1.1: - Add support for inline pragmas, and improve support for type signatures (patch by Jonas Duregard) 0.1.0: - Used the th-lift library to autogenerate the instances of Lift in Language.Haskell.TH.Instances.Lift - Added support for the new features of template-haskell-2.4.0.0: contexts, kinds, bang patterns, unboxed word literals. - Updated use of haskell-src-exts in response to API changes. - Added ToDecs class because some HSE Decls don't map to a single Dec. (patch by Jonas Duregard) 0.0.6: - last version released by Matt Morrow before his disappearance haskell-src-meta-0.8.0.1/README.md0000644000000000000000000000160213113607060014453 0ustar0000000000000000The `haskell-src-meta` Package [![Hackage](https://img.shields.io/hackage/v/haskell-src-meta.svg)](https://hackage.haskell.org/package/haskell-src-meta) [![Build Status](https://travis-ci.org/mainland/haskell-src-meta.svg)](https://travis-ci.org/mainland/haskell-src-meta) ================== `haskell-src-meta` is a package originally by Matt Morrow for converting a parsed AST from `haskell-src-exts` to a TH AST for use in splices and quasiquoters. The last version Matt released before he disappeared from the Haskell community was 0.0.6, but by that time his library was already popular, so some community members eventually decided to take over maintenance of the package, keeping it up to date with the latest versions of TH etc. I don't really view this as "my" package so if you want write access to the github repository, or you think you could do a better job as maintainer, just ask. haskell-src-meta-0.8.0.1/Setup.lhs0000644000000000000000000000010113113607060014775 0ustar0000000000000000> import Distribution.Simple > main :: IO () > main = defaultMainhaskell-src-meta-0.8.0.1/haskell-src-meta.cabal0000644000000000000000000000356313113607060017324 0ustar0000000000000000name: haskell-src-meta version: 0.8.0.1 cabal-version: >= 1.8 build-type: Simple license: BSD3 license-file: LICENSE category: Language, Template Haskell author: Matt Morrow copyright: (c) Matt Morrow maintainer: Ben Millwood bug-reports: https://github.com/bmillwood/haskell-src-meta/issues tested-with: GHC == 7.6.3, GHC == 7.8.3, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 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: ChangeLog README.md examples/*.hs library build-depends: base >= 4.6 && < 4.11, haskell-src-exts >= 1.17 && < 1.20, pretty >= 1.0 && < 1.2, syb >= 0.1 && < 0.8, template-haskell >= 2.8 && < 2.13, th-orphans >= 0.9.1 && < 0.14 if impl(ghc < 7.8) build-depends: safe <= 0.3.9 hs-source-dirs: src exposed-modules: Language.Haskell.Meta Language.Haskell.Meta.Parse Language.Haskell.Meta.Syntax.Translate Language.Haskell.Meta.Utils test-suite unit type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Main.hs build-depends: HUnit >= 1.2 && < 1.7, base >= 4.5 && < 4.11, haskell-src-exts >= 1.17 && < 1.20, haskell-src-meta, pretty >= 1.0 && < 1.2, template-haskell >= 2.7 && < 2.13, test-framework >= 0.8 && < 0.9, test-framework-hunit >= 0.3 && < 0.4 source-repository head type: git location: git://github.com/bmillwood/haskell-src-meta.git haskell-src-meta-0.8.0.1/LICENSE0000644000000000000000000001744013113607060014210 0ustar0000000000000000----------------------------------------------------------------------------- ----------------------------------------------------------------------------- metaquote Copyright (c) Matt Morrow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The names of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- th-lift Copyright (c) Ian Lynagh. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The names of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- haskell-src-exts This library (Haskell Source eXtensions) is derived from code from several sources: * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). The full text of these licenses is reproduced below. All of the licenses are BSD-style or compatible. ----------------------------------------------------------------------------- The haskell-src-exts package itself is distributable under the modified BSD license: Copyright (c) 2005, Niklas Broberg All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The names of its contributors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------- The Glasgow Haskell Compiler License Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------- Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: Copyright (c) 2002 Simon Peyton Jones The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, including this Notice. Modified versions of this Report may also be copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. ----------------------------------------------------------------------------- haskell-src-meta-0.8.0.1/examples/0000755000000000000000000000000013113607060015013 5ustar0000000000000000haskell-src-meta-0.8.0.1/examples/SKI.hs0000644000000000000000000001042313113607060015775 0ustar0000000000000000{-# 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 -} haskell-src-meta-0.8.0.1/examples/HsHere.hs0000644000000000000000000000622013113607060016525 0ustar0000000000000000{-# 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 ']' haskell-src-meta-0.8.0.1/examples/Hs.hs0000644000000000000000000000153413113607060015724 0ustar0000000000000000 -- | 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) } haskell-src-meta-0.8.0.1/examples/BF.hs0000644000000000000000000001224613113607060015643 0ustar0000000000000000{-# 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)], []) -} haskell-src-meta-0.8.0.1/src/0000755000000000000000000000000013113607060013764 5ustar0000000000000000haskell-src-meta-0.8.0.1/src/Language/0000755000000000000000000000000013113607060015507 5ustar0000000000000000haskell-src-meta-0.8.0.1/src/Language/Haskell/0000755000000000000000000000000013113607060017072 5ustar0000000000000000haskell-src-meta-0.8.0.1/src/Language/Haskell/Meta.hs0000644000000000000000000000074213113607060020317 0ustar0000000000000000{- | Module : Language.Haskell.Meta Copyright : (c) Matt Morrow 2008 License : BSD3 Maintainer : Matt Morrow Stability : experimental Portability : portable (template-haskell) -} module Language.Haskell.Meta ( module Language.Haskell.Meta.Parse, module Language.Haskell.Meta.Syntax.Translate ) where import Language.Haskell.Meta.Parse import Language.Haskell.Meta.Syntax.Translate import Language.Haskell.TH.Instances() haskell-src-meta-0.8.0.1/src/Language/Haskell/Meta/0000755000000000000000000000000013113607060017760 5ustar0000000000000000haskell-src-meta-0.8.0.1/src/Language/Haskell/Meta/Parse.hs0000644000000000000000000001117413113607060021372 0ustar0000000000000000{-# LANGUAGE CPP #-} {- | Module : Language.Haskell.Meta.Parse Copyright : (c) Matt Morrow 2008 License : BSD3 Maintainer : Matt Morrow Stability : experimental Portability : portable (template-haskell) -} module Language.Haskell.Meta.Parse ( parsePat, parseExp, parseType, parseDecs, myDefaultParseMode, myDefaultExtensions, parseResultToEither, parseHsModule, parseHsDecls, parseHsType, parseHsExp, parseHsPat, pprHsModule, moduleDecls, noSrcSpanInfo, emptyHsModule ) where #if MIN_VERSION_template_haskell(2,11,0) import Language.Haskell.TH.Syntax hiding (Extension(..)) #else import Language.Haskell.TH.Syntax #endif import Language.Haskell.Meta.Syntax.Translate #if MIN_VERSION_haskell_src_exts(1,18,0) import qualified Language.Haskell.Exts.Syntax as Hs import Language.Haskell.Exts.Fixity as Fix import Language.Haskell.Exts.Parser hiding (parseExp, parseType, parsePat) #else import qualified Language.Haskell.Exts.Annotated.Syntax as Hs import Language.Haskell.Exts.Annotated.Fixity as Fix import Language.Haskell.Exts.Annotated.Parser hiding (parseExp, parseType, parsePat) #endif import qualified Language.Haskell.Exts.SrcLoc as Hs import Language.Haskell.Exts.Extension import Language.Haskell.Exts.Pretty import Language.Haskell.Exts.Parser (ParseMode(..), ParseResult(..)) ----------------------------------------------------------------------------- -- * template-haskell parsePat :: String -> Either String Pat parsePat = either Left (Right . toPat) . parseHsPat parseExp :: String -> Either String Exp parseExp = either Left (Right . toExp) . parseHsExp parseType :: String -> Either String Type parseType = either Left (Right . toType) . parseHsType parseDecs :: String -> Either String [Dec] parseDecs = either Left (Right . toDecs) . parseHsDecls ----------------------------------------------------------------------------- {-# DEPRECATED myDefaultParseMode, myDefaultExtensions "The provided ParseModes aren't very meaningful, use your own instead" #-} myDefaultParseMode :: ParseMode myDefaultParseMode = ParseMode {parseFilename = [] ,baseLanguage = Haskell2010 ,extensions = map EnableExtension myDefaultExtensions ,ignoreLinePragmas = False ,ignoreLanguagePragmas = False ,fixities = Nothing ,ignoreFunctionArity = False } myDefaultExtensions :: [KnownExtension] myDefaultExtensions = [PostfixOperators ,QuasiQuotes ,UnicodeSyntax ,PatternSignatures ,MagicHash ,ForeignFunctionInterface ,TemplateHaskell ,RankNTypes ,MultiParamTypeClasses ,RecursiveDo] parseResultToEither :: ParseResult a -> Either String a parseResultToEither (ParseOk a) = Right a parseResultToEither (ParseFailed loc e) = let line = Hs.srcLine loc - 1 in Left (unlines [show line,show loc,e]) parseHsModule :: String -> Either String (Hs.Module Hs.SrcSpanInfo) parseHsModule = parseResultToEither . parseModuleWithMode myDefaultParseMode parseHsDecls :: String -> Either String [Hs.Decl Hs.SrcSpanInfo] parseHsDecls = either Left (Right . moduleDecls) . parseResultToEither . parseModuleWithMode myDefaultParseMode parseHsType :: String -> Either String (Hs.Type Hs.SrcSpanInfo) parseHsType = parseResultToEither . parseTypeWithMode myDefaultParseMode parseHsExp :: String -> Either String (Hs.Exp Hs.SrcSpanInfo) parseHsExp = parseResultToEither . parseExpWithMode myDefaultParseMode parseHsPat :: String -> Either String (Hs.Pat Hs.SrcSpanInfo) parseHsPat = parseResultToEither . parsePatWithMode myDefaultParseMode pprHsModule :: Hs.Module Hs.SrcSpanInfo -> String pprHsModule = prettyPrint moduleDecls :: Hs.Module Hs.SrcSpanInfo -> [Hs.Decl Hs.SrcSpanInfo] moduleDecls (Hs.Module _ _ _ _ x) = x -- mkModule :: String -> Hs.Module -- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] [] emptyHsModule :: String -> Hs.Module Hs.SrcSpanInfo emptyHsModule n = (Hs.Module noSrcSpanInfo (Just (Hs.ModuleHead noSrcSpanInfo (Hs.ModuleName noSrcSpanInfo n) Nothing Nothing)) [] [] []) noSrcSpanInfo = Hs.noInfoSpan (Hs.mkSrcSpan Hs.noLoc Hs.noLoc) {- ghci> :i Module data Module = Module SrcLoc ModuleName [OptionPragma] (Maybe WarningText) (Maybe [ExportSpec]) [ImportDecl] [Decl] -- Defined in Language.Haskell.Exts.Syntax instance Show Module -- Defined in Language.Haskell.Exts.Syntax -} ----------------------------------------------------------------------------- haskell-src-meta-0.8.0.1/src/Language/Haskell/Meta/Utils.hs0000644000000000000000000002674213113607060021427 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell, RankNTypes, StandaloneDeriving, DeriveDataTypeable, PatternGuards, FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-} -- | This module is a staging ground -- for to-be-organized-and-merged-nicely code. module Language.Haskell.Meta.Utils where import Data.List (findIndex) import Data.Typeable import Data.Generics hiding(Fixity) import Language.Haskell.Meta import System.IO.Unsafe(unsafePerformIO) import Language.Haskell.Exts.Pretty(prettyPrint) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr import Text.PrettyPrint import Control.Monad ----------------------------------------------------------------------------- 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 -- | The type passed in must have a @Show@ instance which -- produces a valid Haskell expression. Returns an empty -- @String@ if this is not the case. This is not TH-specific, -- but useful in general. pretty :: (Show a) => a -> String pretty a = case parseHsExp (show a) of Left _ -> [] Right e -> prettyPrint e pp :: (Data a, Ppr a) => a -> String pp = pprint . cleanNames ppDoc :: (Data a, Ppr a) => a -> Doc ppDoc = text . pp gpretty :: (Data a) => a -> String gpretty = either (const []) prettyPrint . parseHsExp . gshow instance Show ExpQ where show = show . cleanNames . unsafeRunQ instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unsafeRunQ instance Show DecQ where show = show . cleanNames . unsafeRunQ instance Show TypeQ where show = show . cleanNames . unsafeRunQ instance Show (Q String) where show = unsafeRunQ instance Show (Q Doc) where show = show . unsafeRunQ #if !MIN_VERSION_th_orphans(0,12,0) #if MIN_VERSION_base(4,7,0) deriving instance Typeable Q #else deriving instance Typeable1 Q #endif deriving instance Typeable QuasiQuoter #endif -- | @unsafeRunQ = unsafePerformIO . runQ@ unsafeRunQ :: Q a -> a unsafeRunQ = unsafePerformIO . runQ nameToRawCodeStr :: Name -> String nameToRawCodeStr n = let s = showNameParens n in case nameSpaceOf n of Just VarName -> "'"++s Just DataName -> "'"++s Just TcClsName -> "''"++s _ -> concat ["(mkName \"", filter (/='"') s, "\")"] where showNameParens :: Name -> String showNameParens n = let nb = nameBase n in case nb of (c:_) | isSym c -> concat ["(",nb,")"] _ -> nb isSym :: Char -> Bool isSym = (`elem` "><.\\/!@#$%^&*-+?:|") ----------------------------------------------------------------------------- (|$|) :: ExpQ -> ExpQ -> ExpQ infixr 0 |$| f |$| x = [|$f $x|] (|.|) :: ExpQ -> ExpQ -> ExpQ infixr 9 |.| g |.| f = [|$g . $f|] (|->|) :: TypeQ -> TypeQ -> TypeQ infixr 9 |->| a |->| b = appT (appT arrowT a) b unForall :: Type -> Type unForall (ForallT _ _ t) = t unForall t = t functionT :: [TypeQ] -> TypeQ functionT = foldl1 (|->|) mkVarT :: String -> TypeQ mkVarT = varT . mkName -- | Infinite list of names composed of lowercase letters myNames :: [Name] myNames = let xs = fmap (:[]) ['a'..'z'] ys = iterate (join (zipWith (++))) xs in fmap mkName (concat ys) -- | Generalisation of renameTs renameThings _ env new acc [] = (reverse acc, env, new) renameThings f env new acc (t:ts) = let (t', env', new') = f env new t in renameThings f env' new' (t':acc) ts -- | renameT applied to a list of types renameTs :: [(Name, Name)] -> [Name] -> [Type] -> [Type] -> ([Type], [(Name,Name)], [Name]) renameTs = renameThings renameT -- | Rename type variables in the Type according to the given association -- list. Normalise constructor names (remove qualification, etc.) -- If a name is not found in the association list, replace it with one from -- the fresh names list, and add this translation to the returned list. -- The fresh names list should be infinite; myNames is a good example. renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name]) renameT env [] _ = error "renameT: ran out of names!" renameT env (x:new) (VarT n) | Just n' <- lookup n env = (VarT n',env,x:new) | otherwise = (VarT x, (n,x):env, new) renameT env new (ConT n) = (ConT (normaliseName n), env, new) renameT env new t@(TupleT {}) = (t,env,new) renameT env new ArrowT = (ArrowT,env,new) renameT env new ListT = (ListT,env,new) renameT env new (AppT t t') = let (s,env',new') = renameT env new t (s',env'',new'') = renameT env' new' t' in (AppT s s', env'', new'') renameT env new (ForallT ns cxt t) = let (ns',env2,new2) = renameTs env new [] (fmap (VarT . toName) ns) ns'' = fmap unVarT ns' (cxt',env3,new3) = renamePreds env2 new2 [] cxt (t',env4,new4) = renameT env3 new3 t in (ForallT ns'' cxt' t', env4, new4) where unVarT (VarT n) = PlainTV n renamePreds = renameThings renamePred #if MIN_VERSION_template_haskell(2,10,0) renamePred = renameT #else renamePred env new (ClassP n ts) = let (ts', env', new') = renameTs env new [] ts in (ClassP (normaliseName n) ts', env', new') renamePred env new (EqualP t1 t2) = let (t1', env1, new1) = renameT env new t1 (t2', env2, new2) = renameT env1 new1 t2 in (EqualP t1' t2', env2, new2) #endif -- | Remove qualification, etc. normaliseName :: Name -> Name normaliseName = mkName . nameBase applyT :: Type -> Type -> Type applyT (ForallT [] _ t) t' = t `AppT` t' applyT (ForallT (n:ns) cxt t) t' = ForallT ns cxt (substT [(toName n,t')] (fmap toName ns) t) applyT t t' = t `AppT` t' substT :: [(Name, Type)] -> [Name] -> Type -> Type substT env bnd (ForallT ns _ t) = substT env (fmap toName ns++bnd) t substT env bnd t@(VarT n) | n `elem` bnd = t | otherwise = maybe t id (lookup n env) substT env bnd (AppT t t') = AppT (substT env bnd t) (substT env bnd t') substT _ _ t = t splitCon :: Con -> (Name,[Type]) splitCon c = (conName c, conTypes c) strictTypeTy :: StrictType -> Type strictTypeTy (_,t) = t varStrictTypeTy :: VarStrictType -> Type varStrictTypeTy (_,_,t) = t conTypes :: Con -> [Type] conTypes (NormalC _ sts) = fmap strictTypeTy sts conTypes (RecC _ vts) = fmap varStrictTypeTy vts conTypes (InfixC t _ t') = fmap strictTypeTy [t,t'] conTypes (ForallC _ _ c) = conTypes c conToConType :: Type -> Con -> Type conToConType ofType con = foldr (\a b -> AppT (AppT ArrowT a) b) ofType (conTypes con) decCons :: Dec -> [Con] #if MIN_VERSION_template_haskell(2,11,0) decCons (DataD _ _ _ _ cons _) = cons decCons (NewtypeD _ _ _ _ con _) = [con] #else decCons (DataD _ _ _ cons _) = cons decCons (NewtypeD _ _ _ con _) = [con] #endif decCons _ = [] decTyVars :: Dec -> [TyVarBndr] #if MIN_VERSION_template_haskell(2,11,0) decTyVars (DataD _ _ ns _ _ _) = ns decTyVars (NewtypeD _ _ ns _ _ _) = ns #else decTyVars (DataD _ _ ns _ _) = ns decTyVars (NewtypeD _ _ ns _ _) = ns #endif decTyVars (TySynD _ ns _) = ns decTyVars (ClassD _ _ ns _ _) = ns decTyVars _ = [] decName :: Dec -> Maybe Name decName (FunD n _) = Just n #if MIN_VERSION_template_haskell(2,11,0) decName (DataD _ n _ _ _ _) = Just n decName (NewtypeD _ n _ _ _ _) = Just n #else decName (DataD _ n _ _ _) = Just n decName (NewtypeD _ n _ _ _) = Just n #endif decName (TySynD n _ _) = Just n decName (ClassD _ n _ _ _) = Just n decName (SigD n _) = Just n decName (ForeignD fgn) = Just (foreignName fgn) decName _ = Nothing foreignName :: Foreign -> Name foreignName (ImportF _ _ _ n _) = n foreignName (ExportF _ _ n _) = n unwindT :: Type -> [Type] unwindT = go where go :: Type -> [Type] go (ForallT _ _ t) = go t go (AppT (AppT ArrowT t) t') = t : go t' go _ = [] unwindE :: Exp -> [Exp] unwindE = go [] where go acc (e `AppE` e') = go (e':acc) e go acc e = e:acc -- | The arity of a Type. arityT :: Type -> Int arityT = go 0 where go :: Int -> Type -> Int go n (ForallT _ _ t) = go n t go n (AppT (AppT ArrowT _) t) = let n' = n+1 in n' `seq` go n' t go n _ = n typeToName :: Type -> Maybe Name typeToName t | ConT n <- t = Just n | ArrowT <- t = Just ''(->) | ListT <- t = Just ''[] | TupleT n <- t = Just $ tupleTypeName n | ForallT _ _ t' <- t = typeToName t' | otherwise = Nothing -- | Randomly useful. nameSpaceOf :: Name -> Maybe NameSpace nameSpaceOf (Name _ (NameG ns _ _)) = Just ns nameSpaceOf _ = Nothing conName :: Con -> Name conName (RecC n _) = n conName (NormalC n _) = n conName (InfixC _ n _) = n conName (ForallC _ _ con) = conName con recCName :: Con -> Maybe Name recCName (RecC n _) = Just n recCName _ = Nothing dataDCons :: Dec -> [Con] #if MIN_VERSION_template_haskell(2,11,0) dataDCons (DataD _ _ _ _ cons _) = cons #else dataDCons (DataD _ _ _ cons _) = cons #endif dataDCons _ = [] fromDataConI :: Info -> Q (Maybe Exp) #if MIN_VERSION_template_haskell(2,11,0) fromDataConI (DataConI dConN ty tyConN) = #else fromDataConI (DataConI dConN ty tyConN fxty) = #endif let n = arityT ty in replicateM n (newName "a") >>= \ns -> return (Just (LamE [ConP dConN (fmap VarP ns)] (TupE $ fmap VarE ns))) fromDataConI _ = return Nothing fromTyConI :: Info -> Maybe Dec fromTyConI (TyConI dec) = Just dec fromTyConI _ = Nothing mkFunD :: Name -> [Pat] -> Exp -> Dec mkFunD f xs e = FunD f [Clause xs (NormalB e) []] mkClauseQ :: [PatQ] -> ExpQ -> ClauseQ mkClauseQ ps e = clause ps (normalB e) [] ----------------------------------------------------------------------------- -- | The strategy for producing QuasiQuoters which -- this datatype aims to facilitate is as follows. -- Given a collection of datatypes which make up -- the to-be-quasiquoted languages AST, make each -- type in this collection an instance of at least -- @Show@ and @Lift@. Now, assuming @parsePat@ and -- @parseExp@, both of type @String -> Q a@ (where @a@ -- is the top level type of the AST), are the pair of -- 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 } quasify :: (Show a, Lift a) => Quoter a -> QuasiQuoter quasify q = QuasiQuoter (toExpQ (expQ q)) (toPatQ (patQ q)) -} toExpQ :: (Lift a) => (String -> Q a) -> (String -> ExpQ) toExpQ parseQ = (lift =<<) . parseQ toPatQ :: (Show a) => (String -> Q a) -> (String -> PatQ) toPatQ parseQ = (showToPatQ =<<) . parseQ showToPatQ :: (Show a) => a -> PatQ showToPatQ = either fail return . parsePat . show ----------------------------------------------------------------------------- eitherQ :: (e -> String) -> Either e a -> Q a eitherQ toStr = either (fail . toStr) return ----------------------------------------------------------------------------- normalizeT :: (Data a) => a -> a normalizeT = everywhere (mkT go) where go :: Type -> Type go (ConT n) | n == ''[] = ListT go (AppT (TupleT 1) t) = t go (ConT n) | Just m <- findIndex (== n) tupleNames = TupleT (m + 2) where tupleNames = map tupleTypeName [2 .. 64] go t = t ----------------------------------------------------------------------------- haskell-src-meta-0.8.0.1/src/Language/Haskell/Meta/Syntax/0000755000000000000000000000000013113607060021246 5ustar0000000000000000haskell-src-meta-0.8.0.1/src/Language/Haskell/Meta/Syntax/Translate.hs0000644000000000000000000006216213113607060023546 0ustar0000000000000000{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-} {- | Module : Language.Haskell.Meta.Syntax.Translate Copyright : (c) Matt Morrow 2008 License : BSD3 Maintainer : Matt Morrow Stability : experimental Portability : portable (template-haskell) -} module Language.Haskell.Meta.Syntax.Translate ( module Language.Haskell.Meta.Syntax.Translate ) where import Data.Char (ord) import Data.Typeable import Data.List (foldl', nub, (\\)) import Language.Haskell.TH.Syntax import qualified Language.Haskell.Exts.SrcLoc as Hs #if MIN_VERSION_haskell_src_exts(1,18,0) import qualified Language.Haskell.Exts.Syntax as Hs #else import qualified Language.Haskell.Exts.Annotated.Syntax as Hs #endif ----------------------------------------------------------------------------- class ToName a where toName :: a -> Name class ToNames a where toNames :: a -> [Name] class ToLit a where toLit :: a -> Lit class ToType a where toType :: a -> Type class ToPat a where toPat :: a -> Pat class ToExp a where toExp :: a -> Exp class ToDecs a where toDecs :: a -> [Dec] class ToDec a where toDec :: a -> Dec class ToStmt a where toStmt :: a -> Stmt class ToLoc a where toLoc :: a -> Loc class ToCxt a where toCxt :: a -> Cxt class ToPred a where toPred :: a -> Pred class ToTyVars a where toTyVars :: a -> [TyVarBndr] #if MIN_VERSION_haskell_src_exts(1,18,0) class ToMaybeKind a where toMaybeKind :: a -> Maybe Kind #endif #if MIN_VERSION_template_haskell(2,11,0) class ToInjectivityAnn a where toInjectivityAnn :: a -> InjectivityAnn #endif #if MIN_VERSION_template_haskell(2,12,0) #elif MIN_VERSION_template_haskell(2,11,0) type DerivClause = Pred #else type DerivClause = Name #endif class ToDerivClauses a where toDerivClauses :: a -> [DerivClause] -- for error messages moduleName = "Language.Haskell.Meta.Syntax.Translate" -- When to use each of these isn't always clear: prefer 'todo' if unsure. noTH :: (Functor f, Show (f ())) => String -> f e -> a noTH fun thing = error . concat $ [moduleName, ".", fun, ": template-haskell has no representation for: ", show (fmap (const ()) thing)] noTHyet :: (Functor f, Show (f ())) => String -> String -> f e -> a noTHyet fun minVersion thing = error . concat $ [moduleName, ".", fun, ": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")", " has no representation for: ", show (fmap (const ()) thing)] todo :: (Functor f, Show (f ())) => String -> f e -> a todo fun thing = error . concat $ [moduleName, ".", fun, ": not implemented: ", show (fmap (const ()) thing)] nonsense :: (Functor f, Show (f ())) => String -> String -> f e -> a nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun, ": nonsensical: ", inparticular, ": ", show (fmap (const ()) thing)] ----------------------------------------------------------------------------- instance ToExp Lit where toExp = LitE instance (ToExp a) => ToExp [a] where toExp = ListE . fmap toExp instance (ToExp a, ToExp b) => ToExp (a,b) where toExp (a,b) = TupE [toExp a, toExp b] instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where toExp (a,b,c) = TupE [toExp a, toExp b, toExp c] instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d] instance ToPat Lit where toPat = LitP instance (ToPat a) => ToPat [a] where toPat = ListP . fmap toPat instance (ToPat a, ToPat b) => ToPat (a,b) where toPat (a,b) = TupP [toPat a, toPat b] instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where toPat (a,b,c) = TupP [toPat a, toPat b, toPat c] instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where toPat (a,b,c,d) = TupP [toPat a, toPat b, toPat c, toPat d] instance ToLit Char where toLit = CharL instance ToLit String where toLit = StringL instance ToLit Integer where toLit = IntegerL instance ToLit Int where toLit = IntegerL . toInteger instance ToLit Float where toLit = RationalL . toRational instance ToLit Double where toLit = RationalL . toRational ----------------------------------------------------------------------------- -- * ToName {String,HsName,Module,HsSpecialCon,HsQName} instance ToName String where toName = mkName instance ToName (Hs.Name l) where toName (Hs.Ident _ s) = toName s toName (Hs.Symbol _ s) = toName s instance ToName (Hs.SpecialCon l) where toName (Hs.UnitCon _) = '() toName (Hs.ListCon _) = '[] toName (Hs.FunCon _) = ''(->) toName (Hs.TupleCon _ _ n) | n<2 = '() | otherwise = let x = maybe [] (++".") (nameModule '(,)) in mkName . concat $ x : ["(",replicate (n-1) ',',")"] toName (Hs.Cons _) = '(:) instance ToName (Hs.QName l) where -- toName (Hs.Qual (Hs.Module []) n) = toName n toName (Hs.Qual _ (Hs.ModuleName _ []) n) = toName n toName (Hs.Qual _ (Hs.ModuleName _ m) n) = let m' = show . toName $ m n' = show . toName $ n in toName . concat $ [m',".",n'] toName (Hs.UnQual _ n) = toName n toName (Hs.Special _ s) = toName s instance ToName (Hs.Op l) where toName (Hs.VarOp _ n) = toName n toName (Hs.ConOp _ n) = toName n ----------------------------------------------------------------------------- -- * ToLit HsLiteral instance ToLit (Hs.Literal l) where toLit (Hs.Char _ a _) = CharL a toLit (Hs.String _ a _) = StringL a toLit (Hs.Int _ a _) = IntegerL a toLit (Hs.Frac _ a _) = RationalL a toLit l@Hs.PrimChar{} = noTH "toLit" l toLit (Hs.PrimString _ a _) = StringPrimL (map toWord8 a) where toWord8 = fromIntegral . ord toLit (Hs.PrimInt _ a _) = IntPrimL a toLit (Hs.PrimFloat _ a _) = FloatPrimL a toLit (Hs.PrimDouble _ a _) = DoublePrimL a toLit (Hs.PrimWord _ a _) = WordPrimL a ----------------------------------------------------------------------------- -- * ToPat HsPat instance ToPat (Hs.Pat l) where toPat (Hs.PVar _ n) = VarP (toName n) toPat (Hs.PLit _ (Hs.Signless _) l) = LitP (toLit l) toPat (Hs.PLit _ (Hs.Negative _) l) = LitP $ case toLit l of IntegerL z -> IntegerL (negate z) RationalL q -> RationalL (negate q) IntPrimL z' -> IntPrimL (negate z') FloatPrimL r' -> FloatPrimL (negate r') DoublePrimL r'' -> DoublePrimL (negate r'') _ -> nonsense "toPat" "negating wrong kind of literal" l toPat (Hs.PInfixApp _ p n q) = UInfixP (toPat p) (toName n) (toPat q) toPat (Hs.PApp _ n ps) = ConP (toName n) (fmap toPat ps) toPat (Hs.PTuple _ Hs.Boxed ps) = TupP (fmap toPat ps) toPat (Hs.PTuple _ Hs.Unboxed ps) = UnboxedTupP (fmap toPat ps) toPat (Hs.PList _ ps) = ListP (fmap toPat ps) toPat (Hs.PParen _ p) = ParensP (toPat p) toPat (Hs.PRec _ n pfs) = let toFieldPat (Hs.PFieldPat _ n p) = (toName n, toPat p) in RecP (toName n) (fmap toFieldPat pfs) toPat (Hs.PAsPat _ n p) = AsP (toName n) (toPat p) toPat (Hs.PWildCard _) = WildP toPat (Hs.PIrrPat _ p) = TildeP (toPat p) toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t) toPat (Hs.PViewPat _ e p) = ViewP (toExp e) (toPat p) -- regular pattern toPat p@Hs.PRPat{} = noTH "toPat" p -- XML stuff toPat p@Hs.PXTag{} = noTH "toPat" p toPat p@Hs.PXETag{} = noTH "toPat" p toPat p@Hs.PXPcdata{} = noTH "toPat" p toPat p@Hs.PXPatTag{} = noTH "toPat" p toPat (Hs.PBangPat _ p) = BangP (toPat p) toPat p = todo "toPat" p ----------------------------------------------------------------------------- -- * ToExp HsExp instance ToExp (Hs.QOp l) where toExp (Hs.QVarOp _ n) = VarE (toName n) toExp (Hs.QConOp _ n) = ConE (toName n) toFieldExp :: Hs.FieldUpdate l -> FieldExp toFieldExp (Hs.FieldUpdate _ n e) = (toName n, toExp e) instance ToExp (Hs.Exp l) where toExp (Hs.Var _ n) = VarE (toName n) toExp e@Hs.IPVar{} = noTH "toExp" e toExp (Hs.Con _ n) = ConE (toName n) toExp (Hs.Lit _ l) = LitE (toLit l) toExp (Hs.InfixApp _ e o f) = UInfixE (toExp e) (toExp o) (toExp f) toExp (Hs.App _ e f) = AppE (toExp e) (toExp f) toExp (Hs.NegApp _ e) = AppE (VarE 'negate) (toExp e) toExp (Hs.Lambda _ ps e) = LamE (fmap toPat ps) (toExp e) toExp (Hs.Let _ bs e) = LetE (toDecs bs) (toExp e) toExp (Hs.If _ a b c) = CondE (toExp a) (toExp b) (toExp c) toExp (Hs.MultiIf _ ifs) = MultiIfE (map toGuard ifs) toExp (Hs.Case _ e alts) = CaseE (toExp e) (map toMatch alts) toExp (Hs.Do _ ss) = DoE (map toStmt ss) toExp e@(Hs.MDo _ _) = noTH "toExp" e toExp (Hs.Tuple _ Hs.Boxed xs) = TupE (fmap toExp xs) toExp (Hs.Tuple _ Hs.Unboxed xs) = UnboxedTupE (fmap toExp xs) toExp e@Hs.TupleSection{} = noTH "toExp" e toExp (Hs.List _ xs) = ListE (fmap toExp xs) toExp (Hs.Paren _ e) = ParensE (toExp e) toExp (Hs.LeftSection _ e o) = InfixE (Just . toExp $ e) (toExp o) Nothing toExp (Hs.RightSection _ o f) = InfixE Nothing (toExp o) (Just . toExp $ f) toExp (Hs.RecConstr _ n xs) = RecConE (toName n) (fmap toFieldExp xs) toExp (Hs.RecUpdate _ e xs) = RecUpdE (toExp e) (fmap toFieldExp xs) toExp (Hs.EnumFrom _ e) = ArithSeqE $ FromR (toExp e) toExp (Hs.EnumFromTo _ e f) = ArithSeqE $ FromToR (toExp e) (toExp f) toExp (Hs.EnumFromThen _ e f) = ArithSeqE $ FromThenR (toExp e) (toExp f) toExp (Hs.EnumFromThenTo _ e f g) = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g) toExp (Hs.ListComp _ e ss) = CompE $ map convert ss ++ [NoBindS (toExp e)] where convert (Hs.QualStmt _ st) = toStmt st convert s = noTH "toExp ListComp" s toExp (Hs.ExpTypeSig _ e t) = SigE (toExp e) (toType t) toExp e = todo "toExp" e toMatch :: Hs.Alt l -> Match toMatch (Hs.Alt _ p rhs ds) = Match (toPat p) (toBody rhs) (toDecs ds) toBody :: Hs.Rhs l -> Body toBody (Hs.UnGuardedRhs _ e) = NormalB $ toExp e toBody (Hs.GuardedRhss _ rhss) = GuardedB $ map toGuard rhss toGuard (Hs.GuardedRhs _ stmts e) = (g, toExp e) where g = case map toStmt stmts of [NoBindS x] -> NormalG x xs -> PatG xs instance ToDecs a => ToDecs (Maybe a) where toDecs Nothing = [] toDecs (Just a) = toDecs a instance ToDecs (Hs.Binds l) where toDecs (Hs.BDecls _ ds) = toDecs ds toDecs a@(Hs.IPBinds {}) = noTH "ToDecs Hs.Binds" a instance ToDecs (Hs.ClassDecl l) where toDecs (Hs.ClsDecl _ d) = toDecs d toDecs x = todo "classDecl" x ----------------------------------------------------------------------------- -- * ToLoc SrcLoc instance ToLoc Hs.SrcLoc where toLoc (Hs.SrcLoc fn l c) = Loc fn [] [] (l,c) (-1,-1) ----------------------------------------------------------------------------- -- * ToType HsType instance ToName (Hs.TyVarBind l) where toName (Hs.KindedVar _ n _) = toName n toName (Hs.UnkindedVar _ n) = toName n instance ToName Name where toName = id instance ToName TyVarBndr where toName (PlainTV n) = n toName (KindedTV n _) = n instance ToType (Hs.Kind l) where toType (Hs.KindStar _) = StarT toType (Hs.KindFn _ k1 k2) = toType k1 .->. toType k2 toType (Hs.KindParen _ kp) = toType kp toType (Hs.KindVar _ n) = VarT (toName n) toKind :: Hs.Kind l -> Kind toKind = toType toTyVar :: Hs.TyVarBind l -> TyVarBndr toTyVar (Hs.KindedVar _ n k) = KindedTV (toName n) (toKind k) toTyVar (Hs.UnkindedVar _ n) = PlainTV (toName n) instance ToType (Hs.Type l) where toType (Hs.TyForall _ tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t) toType (Hs.TyFun _ a b) = toType a .->. toType b toType (Hs.TyList _ t) = ListT `AppT` toType t toType (Hs.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts) where tuple = case b of Hs.Boxed -> TupleT Hs.Unboxed -> UnboxedTupleT toType (Hs.TyApp _ a b) = AppT (toType a) (toType b) toType (Hs.TyVar _ n) = VarT (toName n) toType (Hs.TyCon _ qn) = ConT (toName qn) toType (Hs.TyParen _ t) = toType t -- XXX: need to wrap the name in parens! toType (Hs.TyInfix _ a o b) = AppT (AppT (ConT (toName o)) (toType a)) (toType b) toType (Hs.TyKind _ t k) = SigT (toType t) (toKind k) toType t@Hs.TyBang{} = nonsense "toType" "type cannot have strictness annotations in this context" t toStrictType :: Hs.Type l -> StrictType #if MIN_VERSION_template_haskell(2,11,0) toStrictType (Hs.TyBang _ s u t) = (Bang (toUnpack u) (toStrict s), toType t) where toStrict (Hs.LazyTy _) = SourceLazy toStrict (Hs.BangedTy _) = SourceStrict toStrict (Hs.NoStrictAnnot _) = NoSourceStrictness toUnpack (Hs.Unpack _) = SourceUnpack toUnpack (Hs.NoUnpack _) = SourceNoUnpack toUnpack (Hs.NoUnpackPragma _) = NoSourceUnpackedness toStrictType x = (Bang NoSourceUnpackedness NoSourceStrictness, toType x) #elif MIN_VERSION_haskell_src_exts(1,18,0) -- TyBang l (BangType l) (Unpackedness l) (Type l) -- data BangType l = BangedTy l | LazyTy l | NoStrictAnnot l -- data Unpackedness l = Unpack l | NoUnpack l | NoUnpackPragma l toStrictType (Hs.TyBang _ b u t) = (toStrict b u, toType t) where toStrict :: Hs.BangType l -> Hs.Unpackedness l -> Strict toStrict (Hs.BangedTy _) _ = IsStrict toStrict _ (Hs.Unpack _) = Unpacked toStrict _ _ = NotStrict toStrictType x = (NotStrict, toType x) #else toStrictType t@(Hs.TyBang _ _ Hs.TyBang{}) = nonsense "toStrictType" "double strictness annotation" t toStrictType (Hs.TyBang _ (Hs.BangedTy _) t) = (IsStrict, toType t) toStrictType (Hs.TyBang _ (Hs.UnpackedTy _) t) = (Unpacked, toType t) toStrictType t = (NotStrict, toType t) #endif (.->.) :: Type -> Type -> Type a .->. b = AppT (AppT ArrowT a) b instance ToPred (Hs.Asst l) where #if MIN_VERSION_template_haskell(2,10,0) toPred (Hs.ClassA _ n ts) = foldl' AppT (ConT (toName n)) (fmap toType ts) toPred (Hs.InfixA _ t1 n t2) = foldl' AppT (ConT (toName n)) (fmap toType [t1,t2]) toPred (Hs.EqualP _ t1 t2) = foldl' AppT EqualityT (fmap toType [t1,t2]) #else toPred (Hs.ClassA _ n ts) = ClassP (toName n) (fmap toType ts) toPred (Hs.InfixA _ t1 n t2) = ClassP (toName n) (fmap toType [t1, t2]) toPred (Hs.EqualP _ t1 t2) = EqualP (toType t1) (toType t2) #endif toPred a@Hs.IParam{} = noTH "toCxt" a toPred p = todo "toPred" p #if MIN_VERSION_template_haskell(2,12,0) instance ToDerivClauses (Hs.Deriving l) where toDerivClauses (Hs.Deriving _ irules) = [DerivClause Nothing (map toType irules)] #elif MIN_VERSION_template_haskell(2,11,0) instance ToDerivClauses (Hs.Deriving l) where toDerivClauses (Hs.Deriving _ irules) = map toType irules #else instance ToDerivClauses (Hs.Deriving l) where toDerivClauses (Hs.Deriving _ irules) = concatMap toNames irules #endif instance ToDerivClauses a => ToDerivClauses (Maybe a) where toDerivClauses Nothing = [] toDerivClauses (Just a) = toDerivClauses a foldAppT :: Type -> [Type] -> Type foldAppT t ts = foldl' AppT t ts ----------------------------------------------------------------------------- -- * ToStmt HsStmt instance ToStmt (Hs.Stmt l) where toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e) toStmt (Hs.Qualifier _ e) = NoBindS (toExp e) toStmt a@(Hs.LetStmt _ bnds) = LetS (toDecs bnds) toStmt s@Hs.RecStmt{} = noTH "toStmt" s ----------------------------------------------------------------------------- -- * ToDec HsDecl instance ToDec (Hs.Decl l) where toDec (Hs.TypeDecl _ h t) = TySynD (toName h) (toTyVars h) (toType t) toDec a@(Hs.DataDecl _ dOrN cxt h qcds qns) = case dOrN of Hs.DataType _ -> DataD (toCxt cxt) (toName h) (toTyVars h) #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif (fmap qualConDeclToCon qcds) (toDerivClauses qns) Hs.NewType _ -> let qcd = case qcds of [x] -> x _ -> nonsense "toDec" ("newtype with " ++ "wrong number of constructors") a in NewtypeD (toCxt cxt) (toName h) (toTyVars h) #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif (qualConDeclToCon qcd) (toDerivClauses qns) -- This type-signature conversion is just wrong. -- Type variables need to be dealt with. /Jonas toDec a@(Hs.TypeSig _ ns t) -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class! = let xs = fmap (flip SigD (toType t) . toName) ns in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!" toDec (Hs.InlineConlikeSig _ act qn) = PragmaD $ InlineP (toName qn) Inline ConLike (transAct act) toDec (Hs.InlineSig _ b act qn) = PragmaD $ InlineP (toName qn) inline FunLike (transAct act) where inline | b = Inline | otherwise = NoInline #if MIN_VERSION_template_haskell(2,11,0) toDec (Hs.TypeFamDecl _ h sig inj) = OpenTypeFamilyD $ TypeFamilyHead (toName h) (toTyVars h) (maybe NoSig KindSig . toMaybeKind $ sig) (fmap toInjectivityAnn inj) toDec (Hs.DataFamDecl _ _ h sig) = DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig) #elif MIN_VERSION_haskell_src_exts(1,18,0) toDec (Hs.TypeFamDecl _ h sig inj) = FamilyD TypeFam (toName h) (toTyVars h) (toMaybeKind sig) toDec (Hs.DataFamDecl _ _ h sig) = FamilyD DataFam (toName h) (toTyVars h) (toMaybeKind sig) #else toDec (Hs.TypeFamDecl _ h k) = FamilyD TypeFam (toName h) (toTyVars h) (fmap toKind k) -- TODO: do something with context? toDec (Hs.DataFamDecl _ _ h k) = FamilyD DataFam (toName h) (toTyVars h) (fmap toKind k) #endif toDec a@(Hs.FunBind _ mtchs) = hsMatchesToFunD mtchs toDec (Hs.PatBind _ p rhs bnds) = ValD (toPat p) (hsRhsToBody rhs) (toDecs bnds) toDec i@(Hs.InstDecl _ (Just overlap) _ _) = noTH "toDec" (fmap (const ()) overlap, i) -- the 'vars' bit seems to be for: instance forall a. C (T a) where ... -- TH's own parser seems to flat-out ignore them, and honestly I can't see -- that it's obviously wrong to do so. #if MIN_VERSION_template_haskell(2,11,0) toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD Nothing (toCxt irule) (toType irule) (toDecs ids) #else toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD (toCxt irule) (toType irule) (toDecs ids) #endif toDec (Hs.ClassDecl _ cxt h fds decls) = ClassD (toCxt cxt) (toName h) (toTyVars h) (fmap toFunDep fds) (toDecs decls) where toFunDep (Hs.FunDep _ ls rs) = FunDep (fmap toName ls) (fmap toName rs) toDec x = todo "toDec" x #if MIN_VERSION_haskell_src_exts(1,18,0) instance ToMaybeKind (Hs.ResultSig l) where toMaybeKind (Hs.KindSig _ k) = Just $ toKind k toMaybeKind (Hs.TyVarSig _ _) = Nothing instance ToMaybeKind a => ToMaybeKind (Maybe a) where toMaybeKind Nothing = Nothing toMaybeKind (Just a) = toMaybeKind a #endif #if MIN_VERSION_template_haskell(2,11,0) instance ToInjectivityAnn (Hs.InjectivityInfo l) where toInjectivityAnn (Hs.InjectivityInfo _ n ns) = InjectivityAnn (toName n) (fmap toName ns) #endif transAct :: Maybe (Hs.Activation l) -> Phases transAct Nothing = AllPhases transAct (Just (Hs.ActiveFrom _ n)) = FromPhase n transAct (Just (Hs.ActiveUntil _ n)) = BeforePhase n instance ToName (Hs.DeclHead l) where toName (Hs.DHead _ n) = toName n toName (Hs.DHInfix _ _ n) = toName n toName (Hs.DHParen _ h) = toName h toName (Hs.DHApp _ h _) = toName h instance ToTyVars (Hs.DeclHead l) where toTyVars (Hs.DHead _ _) = [] toTyVars (Hs.DHParen _ h) = toTyVars h toTyVars (Hs.DHInfix _ tvb _) = [toTyVar tvb] toTyVars (Hs.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb] instance ToNames a => ToNames (Maybe a) where toNames Nothing = [] toNames (Just a) = toNames a instance ToNames (Hs.Deriving l) where toNames (Hs.Deriving _ irules) = concatMap toNames irules instance ToNames (Hs.InstRule l) where toNames (Hs.IParen _ irule) = toNames irule toNames (Hs.IRule _ _mtvbs _mcxt mihd) = toNames mihd instance ToNames (Hs.InstHead l) where toNames (Hs.IHCon _ n) = [toName n] toNames (Hs.IHInfix _ _ n) = [toName n] toNames (Hs.IHParen _ h) = toNames h toNames (Hs.IHApp _ h _) = toNames h instance ToCxt (Hs.InstRule l) where toCxt (Hs.IRule _ _ cxt _) = toCxt cxt toCxt (Hs.IParen _ irule) = toCxt irule instance ToCxt (Hs.Context l) where toCxt x = case x of Hs.CxEmpty _ -> [] Hs.CxSingle _ x' -> [toPred x'] Hs.CxTuple _ xs -> fmap toPred xs instance ToCxt a => ToCxt (Maybe a) where toCxt Nothing = [] toCxt (Just a) = toCxt a instance ToType (Hs.InstRule l) where toType (Hs.IRule _ _ _ h) = toType h toType (Hs.IParen _ irule) = toType irule instance ToType (Hs.InstHead l) where toType (Hs.IHCon _ qn) = toType qn toType (Hs.IHInfix _ typ qn) = AppT (toType typ) (toType qn) toType (Hs.IHParen _ hd) = toType hd toType (Hs.IHApp _ hd typ) = AppT (toType hd) (toType typ) qualConDeclToCon :: Hs.QualConDecl l -> Con qualConDeclToCon (Hs.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (toTyVars ns) (toCxt cxt) (conDeclToCon cdecl) instance ToTyVars a => ToTyVars (Maybe a) where toTyVars Nothing = [] toTyVars (Just a) = toTyVars a instance ToTyVars a => ToTyVars [a] where toTyVars = concatMap toTyVars instance ToTyVars (Hs.TyVarBind l) where toTyVars tvb = [toTyVar tvb] instance ToType (Hs.QName l) where toType = ConT . toName conDeclToCon :: Hs.ConDecl l -> Con conDeclToCon (Hs.ConDecl _ n tys) = NormalC (toName n) (map toStrictType tys) conDeclToCon (Hs.RecDecl _ n fieldDecls) = RecC (toName n) (concatMap convField fieldDecls) where convField :: Hs.FieldDecl l -> [VarStrictType] convField (Hs.FieldDecl _ ns t) = let (strict, ty) = toStrictType t in map (\n' -> (toName n', strict, ty)) ns hsMatchesToFunD :: [Hs.Match l] -> Dec hsMatchesToFunD [] = FunD (mkName []) [] -- errorish hsMatchesToFunD xs@(Hs.Match _ n _ _ _ : _) = FunD (toName n) (fmap hsMatchToClause xs) hsMatchToClause :: Hs.Match l -> Clause hsMatchToClause (Hs.Match _ _ ps rhs bnds) = Clause (fmap toPat ps) (hsRhsToBody rhs) (toDecs bnds) hsRhsToBody :: Hs.Rhs l -> Body hsRhsToBody (Hs.UnGuardedRhs _ e) = NormalB (toExp e) hsRhsToBody (Hs.GuardedRhss _ hsgrhs) = let fromGuardedB (GuardedB a) = a in GuardedB . concat . fmap (fromGuardedB . hsGuardedRhsToBody) $ hsgrhs hsGuardedRhsToBody :: Hs.GuardedRhs l -> Body hsGuardedRhsToBody (Hs.GuardedRhs _ [] e) = NormalB (toExp e) hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)] hsGuardedRhsToBody (Hs.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss (pgs,ngs) = unzip [(p,n) | (PatG p) <- ss' , n@(NormalG _) <- ss'] e' = toExp e patg = PatG (concat pgs) in GuardedB $ (patg,e') : zip ngs (repeat e') hsStmtToGuard :: Hs.Stmt l -> Guard hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)] hsStmtToGuard (Hs.Qualifier _ e) = NormalG (toExp e) hsStmtToGuard (Hs.LetStmt _ bs) = PatG [LetS (toDecs bs)] ----------------------------------------------------------------------------- -- * ToDecs InstDecl instance ToDecs (Hs.InstDecl l) where toDecs (Hs.InsDecl _ decl) = toDecs decl toDecs d = todo "toDec" d -- * ToDecs HsDecl HsBinds instance ToDecs (Hs.Decl l) where toDecs a@(Hs.TypeSig _ ns t) = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns in xs toDecs (Hs.InfixDecl l assoc Nothing ops) = toDecs (Hs.InfixDecl l assoc (Just 9) ops) toDecs (Hs.InfixDecl _ assoc (Just fixity) ops) = map (\op -> InfixD (Fixity fixity dir) (toName op)) ops where dir = case assoc of Hs.AssocNone _ -> InfixN Hs.AssocLeft _ -> InfixL Hs.AssocRight _ -> InfixR toDecs a = [toDec a] collectVars e = case e of VarT n -> [PlainTV n] AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2 ForallT ns _ t -> collectVars t \\ ns _ -> [] fixForall t = case vs of [] -> t _ -> ForallT vs [] t where vs = collectVars t instance ToDecs a => ToDecs [a] where toDecs a = concatMap toDecs a ----------------------------------------------------------------------------- haskell-src-meta-0.8.0.1/tests/0000755000000000000000000000000013113607060014337 5ustar0000000000000000haskell-src-meta-0.8.0.1/tests/Main.hs0000644000000000000000000000160013113607060015554 0ustar0000000000000000{-# LANGUAGE CPP #-} module Main where import Language.Haskell.Meta.Parse #if MIN_VERSION_haskell_src_exts(1,18,0) import qualified Language.Haskell.Exts as Exts #else import qualified Language.Haskell.Exts.Annotated as Exts #endif import qualified Language.Haskell.TH as TH import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit (Assertion, (@?=)) main :: IO () main = defaultMain tests tests :: [Test] tests = [derivingClausesTest] derivingClausesTest :: Test derivingClausesTest = testCase "Deriving clauses preserved" $ roundTripDecls "data Foo = Foo deriving (A, B, C)" roundTripDecls :: String -> Assertion roundTripDecls s = do declsExts <- liftEither $ parseHsDecls s declsExts' <- liftEither $ parseDecs s >>= parseHsDecls . TH.pprint declsExts' @?= declsExts liftEither :: Monad m => Either String a -> m a liftEither = either fail return