haskell-src-meta-0.6.0.14/0000755000000000000000000000000012712136142013261 5ustar0000000000000000haskell-src-meta-0.6.0.14/LICENSE0000644000000000000000000001744012712136142014274 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.6.0.14/haskell-src-meta.cabal0000644000000000000000000000413112712136142017400 0ustar0000000000000000name: haskell-src-meta version: 0.6.0.14 cabal-version: >= 1.6 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 -- That is to say, "builds with". It's not like we have a testsuite. tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.3, GHC == 7.10.3, GHC == 8.0.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.5 && < 4.10, pretty >= 1.0 && < 1.2, syb >= 0.1 && < 0.7, template-haskell >= 2.7 && < 2.12, th-orphans >= 0.9.1 && < 0.14 -- haskell-src-exts 1.17 is not compatible with versions of GHC prior to 7.8, -- but we still maintain compatibility back to GHC 7.4. if impl(ghc >= 7.8) build-depends: haskell-src-exts >= 1.16 && < 1.18 else build-depends: haskell-src-exts == 1.16.* extensions: CPP, RankNTypes, StandaloneDeriving, TemplateHaskell, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, DeriveDataTypeable, PatternGuards hs-source-dirs: src exposed-modules: Language.Haskell.Meta Language.Haskell.Meta.Parse Language.Haskell.Meta.Parse.Careful Language.Haskell.Meta.Syntax.Translate Language.Haskell.TH.Instances.Lift Language.Haskell.Meta.Utils source-repository head type: git location: git://github.com/bmillwood/haskell-src-meta.git haskell-src-meta-0.6.0.14/ChangeLog0000644000000000000000000000667612712136142015052 0ustar00000000000000000.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.6.0.14/Setup.lhs0000644000000000000000000000010112712136142015061 0ustar0000000000000000> import Distribution.Simple > main :: IO () > main = defaultMainhaskell-src-meta-0.6.0.14/README.md0000644000000000000000000000160212712136142014537 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.6.0.14/examples/0000755000000000000000000000000012712136142015077 5ustar0000000000000000haskell-src-meta-0.6.0.14/examples/HsHere.hs0000644000000000000000000000622012712136142016611 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.6.0.14/examples/Hs.hs0000644000000000000000000000153412712136142016010 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.6.0.14/examples/BF.hs0000644000000000000000000001224612712136142015727 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.6.0.14/examples/SKI.hs0000644000000000000000000001042312712136142016061 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.6.0.14/src/0000755000000000000000000000000012712136142014050 5ustar0000000000000000haskell-src-meta-0.6.0.14/src/Language/0000755000000000000000000000000012712136142015573 5ustar0000000000000000haskell-src-meta-0.6.0.14/src/Language/Haskell/0000755000000000000000000000000012712136142017156 5ustar0000000000000000haskell-src-meta-0.6.0.14/src/Language/Haskell/Meta.hs0000644000000000000000000000074312712136142020404 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.6.0.14/src/Language/Haskell/TH/0000755000000000000000000000000012712136142017471 5ustar0000000000000000haskell-src-meta-0.6.0.14/src/Language/Haskell/TH/Instances/0000755000000000000000000000000012712136142021420 5ustar0000000000000000haskell-src-meta-0.6.0.14/src/Language/Haskell/TH/Instances/Lift.hs0000644000000000000000000000107612712136142022656 0ustar0000000000000000{- | Module : Language.Haskell.TH.Instances.Lift Copyright : (c) Matt Morrow 2008 License : BSD3 Maintainer : Matt Morrow Stability : experimental Portability : portable (template-haskell) This module is exported for backwards-compatibility purposes. All it does is re-export the instances defined in "Language.Haskell.TH.Instances", from the th-orphans package. -} module Language.Haskell.TH.Instances.Lift {-# DEPRECATED "Use the th-orphans package instead." #-} () where import Language.Haskell.TH.Instances haskell-src-meta-0.6.0.14/src/Language/Haskell/Meta/0000755000000000000000000000000012712136142020044 5ustar0000000000000000haskell-src-meta-0.6.0.14/src/Language/Haskell/Meta/Utils.hs0000644000000000000000000002674212712136142021513 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.6.0.14/src/Language/Haskell/Meta/Parse.hs0000644000000000000000000001021012712136142021444 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, emptySrcLoc, 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 import qualified Language.Haskell.Exts.Syntax as Hs import Language.Haskell.Exts.Annotated.Fixity as Fix import Language.Haskell.Exts.Extension import Language.Haskell.Exts.Parser hiding (parseExp, parseType, parsePat) import Language.Haskell.Exts.Pretty ----------------------------------------------------------------------------- -- * 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 #if MIN_VERSION_haskell_src_exts(1,17,0) ,ignoreFunctionArity = False #endif } 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 parseHsModule = parseResultToEither . parseModuleWithMode myDefaultParseMode parseHsDecls :: String -> Either String [Hs.Decl] parseHsDecls = either Left (Right . moduleDecls) . parseResultToEither . parseModuleWithMode myDefaultParseMode parseHsType :: String -> Either String Hs.Type parseHsType = parseResultToEither . parseTypeWithMode myDefaultParseMode parseHsExp :: String -> Either String Hs.Exp parseHsExp = parseResultToEither . parseExpWithMode myDefaultParseMode parseHsPat :: String -> Either String Hs.Pat parseHsPat = parseResultToEither . parsePatWithMode myDefaultParseMode pprHsModule :: Hs.Module -> String pprHsModule = prettyPrint moduleDecls :: Hs.Module -> [Hs.Decl] moduleDecls (Hs.Module _ _ _ _ _ _ x) = x -- mkModule :: String -> Hs.Module -- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] [] emptySrcLoc :: Hs.SrcLoc emptySrcLoc = (Hs.SrcLoc [] 0 0) emptyHsModule :: String -> Hs.Module emptyHsModule n = (Hs.Module emptySrcLoc (Hs.ModuleName n) [] Nothing Nothing [] []) {- 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.6.0.14/src/Language/Haskell/Meta/Syntax/0000755000000000000000000000000012712136142021332 5ustar0000000000000000haskell-src-meta-0.6.0.14/src/Language/Haskell/Meta/Syntax/Translate.hs0000644000000000000000000005364312712136142023636 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.Syntax as Hs ----------------------------------------------------------------------------- class ToName a where toName :: 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 -- for error messages moduleName = "Language.Haskell.Meta.Syntax.Translate" -- When to use each of these isn't always clear: prefer 'todo' if unsure. noTH :: Show e => String -> e -> a noTH fun thing = error . concat $ [moduleName, ".", fun, ": template-haskell has no representation for: ", show thing] noTHyet :: Show e => String -> String -> e -> a noTHyet fun minVersion thing = error . concat $ [moduleName, ".", fun, ": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")", " has no representation for: ", show thing] todo :: Show e => String -> e -> a todo fun thing = error . concat $ [moduleName, ".", fun, ": not implemented: ", show thing] nonsense :: Show e => String -> String -> e -> a nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun, ": nonsensical: ", inparticular, ": ", show 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 where toName (Hs.Ident s) = toName s toName (Hs.Symbol s) = toName s instance ToName Hs.Module where toName (Hs.Module _ (Hs.ModuleName s) _ _ _ _ _) = toName s instance ToName Hs.SpecialCon 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 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 where toName (Hs.VarOp n) = toName n toName (Hs.ConOp n) = toName n ----------------------------------------------------------------------------- -- * ToLit HsLiteral instance ToLit Hs.Literal 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 #if MIN_VERSION_template_haskell(2,8,0) toLit (Hs.PrimString a) = StringPrimL (map toWord8 a) where toWord8 = fromIntegral . ord #else toLit (Hs.PrimString a) = StringPrimL a #endif 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 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 where toExp (Hs.QVarOp n) = VarE (toName n) toExp (Hs.QConOp n) = ConE (toName n) toFieldExp :: Hs.FieldUpdate -> FieldExp toFieldExp (Hs.FieldUpdate n e) = (toName n, toExp e) instance ToExp Hs.Exp 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) #if MIN_VERSION_template_haskell(2,8,0) toExp (Hs.MultiIf ifs) = MultiIfE (map toGuard ifs) #else toExp e@Hs.MultiIf{} = noTHyet "toExp" "2.8.0" e #endif 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 -> Match toMatch (Hs.Alt _ p rhs ds) = Match (toPat p) (toBody rhs) (toDecs ds) toBody :: Hs.Rhs -> 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 ----------------------------------------------------------------------------- -- * 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 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 #if MIN_VERSION_template_haskell(2,8,0) instance ToType Hs.Kind where toType Hs.KindStar = StarT toType (Hs.KindFn k1 k2) = toType k1 .->. toType k2 toType (Hs.KindParen kp) = toType kp #if !MIN_VERSION_haskell_src_exts(1,17,0) toType k@Hs.KindBang = noTH "toKind" k #endif toType (Hs.KindVar n) = VarT (toName n) toKind :: Hs.Kind -> Kind toKind = toType #else toKind :: Hs.Kind -> Kind toKind Hs.KindStar = StarK toKind (Hs.KindFn k1 k2) = ArrowK (toKind k1) (toKind k2) toKind (Hs.KindParen kp) = toKind kp toKind k@Hs.KindBang = noTH "toKind" k toKind k@Hs.KindVar{} = noTHyet "toKind" "2.8.0" k #endif /* !MIN_VERSION_template_haskell(2,8,0) */ toTyVar :: Hs.TyVarBind -> TyVarBndr toTyVar (Hs.KindedVar n k) = KindedTV (toName n) (toKind k) toTyVar (Hs.UnkindedVar n) = PlainTV (toName n) instance ToType Hs.Type 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 -> StrictType #if MIN_VERSION_template_haskell(2,11,0) toStrictType (Hs.TyBang Hs.UnpackedTy t) = toStrictType2 SourceUnpack t toStrictType t = toStrictType2 NoSourceUnpackedness t toStrictType2 u t@(Hs.TyBang _ Hs.TyBang{}) = nonsense "toStrictType" "double strictness annotation" t toStrictType2 u (Hs.TyBang Hs.BangedTy t) = (Bang u SourceStrict, toType t) toStrictType2 u (Hs.TyBang Hs.UnpackedTy t) = nonsense "toStrictType" "double unpackedness annotation" t toStrictType2 u t = (Bang u NoSourceStrictness, toType t) #else /* !MIN_VERSION_template_haskell(2,11,0) */ 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 /* !MIN_VERSION_template_haskell(2,11,0) */ (.->.) :: Type -> Type -> Type a .->. b = AppT (AppT ArrowT a) b instance ToCxt Hs.Context where toCxt = fmap toPred 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 #if MIN_VERSION_template_haskell(2,11,0) instance ToCxt [Hs.Deriving] where toCxt = fmap toPred where toPred (qn, ts) = foldl' AppT (ConT (toName qn)) (fmap toType ts) #endif foldAppT :: Type -> [Type] -> Type foldAppT t ts = foldl' AppT t ts ----------------------------------------------------------------------------- -- * ToStmt HsStmt instance ToStmt Hs.Stmt 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 where toDec (Hs.TypeDecl _ n ns t) = TySynD (toName n) (fmap toTyVar ns) (toType t) toDec a@(Hs.DataDecl _ dOrN cxt n ns qcds qns) = case dOrN of Hs.DataType -> DataD (toCxt cxt) (toName n) (fmap toTyVar ns) #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif (fmap qualConDeclToCon qcds) #if MIN_VERSION_template_haskell(2,11,0) (toCxt qns) #else (fmap (toName . fst) qns) #endif Hs.NewType -> let qcd = case qcds of [x] -> x _ -> nonsense "toDec" ("newtype with " ++ "wrong number of constructors") a in NewtypeD (toCxt cxt) (toName n) (fmap toTyVar ns) #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif (qualConDeclToCon qcd) #if MIN_VERSION_template_haskell(2,11,0) (toCxt qns) #else (fmap (toName . fst) qns) #endif -- 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!" #if MIN_VERSION_template_haskell(2,8,0) 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 #else 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,8,0) */ #if MIN_VERSION_template_haskell(2,11,0) toDec (Hs.TypeFamDecl _ n ns k) = OpenTypeFamilyD $ TypeFamilyHead (toName n) (fmap toTyVar ns) (maybe NoSig (KindSig . toKind) k) Nothing -- TODO: do something with context? toDec (Hs.DataFamDecl _ _ n ns k) = DataFamilyD (toName n) (fmap toTyVar ns) (fmap toKind k) #else toDec (Hs.TypeFamDecl _ n ns k) = FamilyD TypeFam (toName n) (fmap toTyVar ns) (fmap toKind k) -- TODO: do something with context? toDec (Hs.DataFamDecl _ _ n ns k) = FamilyD DataFam (toName n) (fmap toTyVar ns) (fmap toKind k) #endif /* MIN_VERSION_template_haskell(2,11,0) */ 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" (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 _vars cxt qname ts ids) = InstanceD Nothing (toCxt cxt) (foldl AppT (ConT (toName qname)) (map toType ts)) (toDecs ids) #else toDec (Hs.InstDecl _ Nothing _vars cxt qname ts ids) = InstanceD (toCxt cxt) (foldl AppT (ConT (toName qname)) (map toType ts)) (toDecs ids) #endif toDec (Hs.ClassDecl _ cxt name ts fds decls) = ClassD (toCxt cxt) (toName name) (fmap toTyVar ts) (fmap toFunDep fds) (fmap classDeclToDec decls) where classDeclToDec cd = case cd of (Hs.ClsDecl d) -> toDec d x -> todo "classDecl" x toFunDep (Hs.FunDep ls rs) = FunDep (fmap toName ls) (fmap toName rs) toDec x = todo "toDec" x #if MIN_VERSION_template_haskell(2,8,0) transAct :: Hs.Activation -> Phases transAct Hs.AlwaysActive = AllPhases transAct (Hs.ActiveFrom n) = FromPhase n transAct (Hs.ActiveUntil n) = BeforePhase n #else transAct act = case act of Hs.AlwaysActive -> Nothing Hs.ActiveFrom n -> Just (True,n) Hs.ActiveUntil n -> Just (False,n) #endif qualConDeclToCon :: Hs.QualConDecl -> Con qualConDeclToCon (Hs.QualConDecl _ [] [] cdecl) = conDeclToCon cdecl qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toTyVar ns) (toCxt cxt) (conDeclToCon cdecl) conDeclToCon :: Hs.ConDecl -> 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 (fields, t) = let (strict, ty) = toStrictType t in map (\field -> (toName field, strict, ty)) fields hsMatchesToFunD :: [Hs.Match] -> Dec hsMatchesToFunD [] = FunD (mkName []) [] -- errorish hsMatchesToFunD xs@(Hs.Match _ n _ _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs) hsMatchToClause :: Hs.Match -> Clause hsMatchToClause (Hs.Match _ _ ps _ rhs bnds) = Clause (fmap toPat ps) (hsRhsToBody rhs) (toDecs bnds) hsRhsToBody :: Hs.Rhs -> 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 -> 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 -> 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 where toDecs (Hs.InsDecl decl) = toDecs decl toDecs d = todo "toDec" d -- * ToDecs HsDecl HsBinds instance ToDecs Hs.Decl where toDecs a@(Hs.TypeSig _ ns t) = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns in xs #if MIN_VERSION_template_haskell(2,8,0) toDecs (Hs.InfixDecl _ assoc 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 #endif 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 instance ToDecs Hs.Binds where toDecs (Hs.BDecls ds) = toDecs ds toDecs a@(Hs.IPBinds {}) = noTH "ToDecs Hs.Binds" a instance ToDecs (Maybe Hs.Binds) where toDecs Nothing = [] toDecs (Just (Hs.BDecls ds)) = toDecs ds ----------------------------------------------------------------------------- haskell-src-meta-0.6.0.14/src/Language/Haskell/Meta/Parse/0000755000000000000000000000000012712136142021116 5ustar0000000000000000haskell-src-meta-0.6.0.14/src/Language/Haskell/Meta/Parse/Careful.hs0000644000000000000000000000503712712136142023040 0ustar0000000000000000{- | DEPRECATED: haskell-src-meta now requires GHC >= 7.4, so this module is no longer necessary. It will be GHC-warning deprecated soon. This module provides the tools to handle operator fixities in infix expressions correctly. The problem we solve is the following. Consider making a quasiquoter which antiquotes to Haskell - for instance, the quasiquoter in allows me to write > myVec :: Vector Double > myVec = [vec| 2+3*4, 5-4-3 |] To correctly parse such expressions, we need to know the fixities and precedences of the operators, so that the above is parsed the same way as > myVec = [vec| 2+(3*4), (5-4)-3 |] There is a danger, if we are not careful in parsing, that the above expression instead parses as > myVec = [vec| (2+3)*4, 5-(4-3) |] which is a surprising bug, and would only be detected through testing at runtime, rather than at compile time. When this danger arises, we use this \"careful\" module. It handles \"unresolved infix\" expressions such as @2+3*4@ in two ways, depending on the version of GHC: * in GHC 7.4 and above (where support for \"unresolved infix\" was added in Template Haskell), resolution of the infix expression is deferred to the compiler, which has all fixities available to it. * prior to GHC 7.4, any ambiguous infix expression is flagged as a parse error at compile time, and the user is advised to resolve the ambiguity by adding parentheses. -} module Language.Haskell.Meta.Parse.Careful( parsePat, parseExp, parseType, parseDecs ) where import qualified Language.Haskell.Meta.Parse as Sloppy import qualified Language.Haskell.Meta.Syntax.Translate as Translate import qualified Language.Haskell.TH as TH import qualified Language.Haskell.Exts.Syntax as Hs doChecked parser translater p = case parser p of Left s -> Left s Right p' | amb p' -> Left "Infix expression could not be resolved as operator fixities are not known. Resolve ambiguity by adding parentheses" | otherwise -> Right (translater p') parsePat :: String -> Either String TH.Pat parsePat = doChecked Sloppy.parseHsPat Translate.toPat parseExp :: String -> Either String TH.Exp parseExp = doChecked Sloppy.parseHsExp Translate.toExp parseType :: String -> Either String TH.Type parseType = doChecked Sloppy.parseHsType Translate.toType parseDecs :: String -> Either String [TH.Dec] parseDecs = doChecked Sloppy.parseHsDecls Translate.toDecs -- This was more complicated, but since support for GHC pre-7.4 was dropped, -- it's no longer necessary amb = const False