haskell-src-meta 0.5 → 0.5.0.2
raw patch · 13 files changed
+2211/−2201 lines, 13 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- LICENSE +168/−168
- README +60/−54
- Setup.lhs +2/−2
- examples/BF.hs +182/−182
- examples/Hs.hs +36/−36
- examples/HsHere.hs +114/−114
- examples/SKI.hs +155/−155
- haskell-src-meta.cabal +46/−46
- src/Language/Haskell/Meta.hs +18/−18
- src/Language/Haskell/Meta/Parse.hs +163/−163
- src/Language/Haskell/Meta/Syntax/Translate.hs +656/−652
- src/Language/Haskell/Meta/Utils.hs +522/−522
- src/Language/Haskell/TH/Instances/Lift.hs +89/−89
LICENSE view
@@ -1,168 +1,168 @@------------------------------------------------------------------------------ ------------------------------------------------------------------------------ - -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. - ------------------------------------------------------------------------------ - +-----------------------------------------------------------------------------+-----------------------------------------------------------------------------++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.++-----------------------------------------------------------------------------+
README view
@@ -1,54 +1,60 @@-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. - -Major changes: - -0.4.0.2 -> 0.5: -- Added support for instance declarations - -0.4.0.1 -> 0.4.0.2: -- Compatibility with GHC 7.2 - -0.4 -> 0.4.0.1: -- Deprecate myDefaultParseMode and myDefaultExtensions in L.H.M.Parse - -0.3 -> 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.2 -> 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.1.1 -> 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.0 -> 0.1.1: -- Add support for inline pragmas, and improve support for type - signatures (patch by Jonas Duregard) - -0.0.6 -> 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) +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.++Major changes:++0.5.0.1 -> 0.5.0.2:+- Fixed bug in translation of tuple constructors++0.5 -> 0.5.0.1:+- Added support for primitive string literals (Only in TH >= 2.5)++0.4.0.2 -> 0.5:+- Added support for instance declarations++0.4.0.1 -> 0.4.0.2:+- Compatibility with GHC 7.2++0.4 -> 0.4.0.1:+- Deprecate myDefaultParseMode and myDefaultExtensions in L.H.M.Parse++0.3 -> 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.2 -> 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.1.1 -> 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.0 -> 0.1.1:+- Add support for inline pragmas, and improve support for type+ signatures (patch by Jonas Duregard)++0.0.6 -> 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)
Setup.lhs view
@@ -1,3 +1,3 @@-> import Distribution.Simple -> main :: IO () +> import Distribution.Simple+> main :: IO () > main = defaultMain
examples/BF.hs view
@@ -1,182 +1,182 @@-{-# LANGUAGE BangPatterns, TemplateHaskell #-} - -module Language.Haskell.Meta.QQ.BF ( - bf,bf2,bfHelloWorld -) where - -import Language.Haskell.Meta (parsePat) -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax - -import Data.Char -import Data.IntMap(IntMap) -import qualified Data.IntMap as IM - - -bf :: QuasiQuoter -bf = QuasiQuoter { quoteExp = bfExpQ, quotePat = bfPatQ } - -bf2 :: QuasiQuoter -bf2 = QuasiQuoter { quoteExp = bf2ExpQ, quotePat = bfPatQ } - -bf2ExpQ :: String -> ExpQ -bf2ExpQ s = [|eval (parse s)|] - -bfExpQ :: String -> ExpQ -bfExpQ s = [|eval_ (parse s)|] - -bfPatQ :: String -> PatQ -bfPatQ s = do - let p = (parsePat - . show - . parse) s - case p of - Left e -> fail e - Right p -> return p - -instance Lift Bf where - lift Inp = [|Inp|] - lift Out = [|Out|] - lift Inc = [|Inc|] - lift Dec = [|Dec|] - lift MovL = [|MovL|] - lift MovR = [|MovR|] - lift (While xs) = [|While $(lift xs)|] - -type Ptr = Int -newtype Mem = Mem (IntMap Int) deriving (Show) - -data Bf = Inp - | Out - | Inc - | Dec - | MovL - | MovR - | While [Bf] - deriving (Eq,Ord,Read,Show) - -data Status = D Ptr Mem - | W Int Status - | R (Int -> Status) - --- ghci> exec (parse helloWorld) --- Hello World! --- (4,Mem (fromList [(0,0),(1,87),(2,100),(3,33),(4,10)])) -bfHelloWorld :: String -bfHelloWorld = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>." - -eval_ :: [Bf] -> (String -> String) -eval_ is = go (run 0 initMem is) - where go (D p m) _ = [] - go (W n s) cs = chr n : go s cs - go (R cont) [] = "*** Exception: bf blocked on input" - go (R cont) (c:cs) = go ((cont . ord) c) cs - -eval :: [Bf] -> String -> (String, (Ptr, Mem)) -eval is = go [] (run 0 initMem is) - where go acc (D p m) _ = (reverse acc, (p, m)) - go acc (W n s) cs = go (chr n:acc) s cs - go _ (R cont) [] = ("*** Exception: bf blocked on input",(-1, Mem IM.empty)) - go acc (R cont) (c:cs) = go acc ((cont . ord) c) cs - -exec :: [Bf] -> IO (Ptr, Mem) -exec is = go (run 0 initMem is) - where go (D p m) = return (p, m) - go (W n s) = putChar (chr n) >> go s - go (R cont) = go . cont . ord =<< getChar - -run :: Ptr -> Mem -> [Bf] -> Status -run dp m is = step dp m is (\dp m -> D dp m) - -step :: Ptr -> Mem -> [Bf] -> (Ptr -> Mem -> Status) -> Status -step dp m [] k = k dp m -step dp m (Inc:is) k = step dp (inc dp m) is k -step dp m (Dec:is) k = step dp (dec dp m) is k -step dp m (MovL:is) k = step (dp-1) m is k -step dp m (MovR:is) k = step (dp+1) m is k -step dp m (Inp:is) k = R (\c -> step dp (wr m dp c) is k) -step dp m (Out:is) k = W (rd m dp) (step dp m is k) -step dp m (While xs:is) k = let go dp m = if rd m dp == 0 - then step dp m is k - else step dp m xs go - in go dp m - -initMem :: Mem -initMem = Mem IM.empty - -inc :: Ptr -> (Mem -> Mem) -dec :: Ptr -> (Mem -> Mem) -rd :: Mem -> Ptr -> Int -wr :: Mem -> Ptr -> Int -> Mem -upd :: Mem -> Ptr -> (Int -> Int) -> Mem -inc p m = upd m p (+1) -dec p m = upd m p (subtract 1) -rd (Mem m) p = maybe 0 id (IM.lookup p m) -wr (Mem m) p n = Mem (IM.insert p n m) -upd m p f = wr m p (f (rd m p)) - -parse :: String -> [Bf] -parse s = go 0 [] s (\_ xs _ -> xs) - where go :: Int -> [Bf] -> String - -> (Int -> [Bf] -> String -> o) -> o - go !n acc [] k = k n (reverse acc) [] - go !n acc (',':cs) k = go (n+1) (Inp:acc) cs k - go !n acc ('.':cs) k = go (n+1) (Out:acc) cs k - go !n acc ('+':cs) k = go (n+1) (Inc:acc) cs k - go !n acc ('-':cs) k = go (n+1) (Dec:acc) cs k - go !n acc ('<':cs) k = go (n+1) (MovL:acc) cs k - go !n acc ('>':cs) k = go (n+1) (MovR:acc) cs k - go !n acc ('[':cs) k = go (n+1) [] cs (\n xs cs -> - go n (While xs:acc) cs k) - go !n acc (']':cs) k = k (n+1) (reverse acc) cs - go !n acc (c :cs) k = go n acc cs k - - - -test0 = do - a <- readFile "prime.bf" - return (parse a) - - - - - - - -{- -data Bf = Inp - | Out - | Inc - | Dec - | MovL - | MovR - | While [Bf] - | Error String - deriving (Eq,Ord,Read,Show) - -parse :: String -> [Bf] -parse s = let p n s = case go n [] s of - (_,xs,[]) -> xs - (n,xs, s) -> xs ++ p n s - in p 0 s - where go :: Int -> [Bf] -> [Char] -> (Int, [Bf], String) - go !n acc [] = (n, reverse acc, []) - go !n acc (',':cs) = go (n+1) (Inp:acc) cs - go !n acc ('.':cs) = go (n+1) (Out:acc) cs - go !n acc ('+':cs) = go (n+1) (Inc:acc) cs - go !n acc ('-':cs) = go (n+1) (Dec:acc) cs - go !n acc ('<':cs) = go (n+1) (MovL:acc) cs - go !n acc ('>':cs) = go (n+1) (MovR:acc) cs - go !n acc ('[':cs) = case go (n+1) [] cs of - (n,xs,cs) -> go n (While xs:acc) cs - go !n acc (']':cs) = (n+1, reverse acc, cs) - go !n acc (c :cs) = (n+1, [Error ("go error: char "++show n - ++" illegal character: "++show c)], []) --} - - - - - - +{-# 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)], [])+-}++++++
examples/Hs.hs view
@@ -1,36 +1,36 @@- - --- | Eat your face! - -module Language.Haskell.Meta.QQ.Hs (hs, pat) where - -import Language.Haskell.Meta (parseExp, parsePat) -import Language.Haskell.Meta.Utils (pretty) -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax - --- | --- > ghci> [$hs|\x -> (x,x)|] 42 --- > (42,42) --- > ghci> (\[$hs|a@(x,_)|] -> (a,x)) (42,88) --- > ((42,88),42) -hs :: QuasiQuoter -hs = QuasiQuoter - { quoteExp = either fail transformE . parseExp - , quotePat = either fail transformP . parsePat - } - -transformE :: Exp -> ExpQ -transformE = return - -transformP :: Pat -> PatQ -transformP = return - -pat :: QuasiQuoter -pat = QuasiQuoter - { quoteExp = quoteExp hs - , quotePat = \s -> case parseExp s of - Left err -> fail err - Right e -> either fail return (parsePat . pretty $ e) - } +++-- | 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)+ }
examples/HsHere.hs view
@@ -1,114 +1,114 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-} - -module Language.Haskell.Meta.QQ.HsHere (here) where - -import Language.Haskell.Meta (parseExp, parsePat) -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import Language.Haskell.Meta.Utils (cleanNames) -import Text.ParserCombinators.ReadP -import Data.Typeable(Typeable) -import Data.Generics(Data) - -data Here - = CodeH Exp - | TextH String - | ManyH [Here] - deriving (Eq,Show,Data,Typeable) - --- | Example: --- --- > a x = [$here| random "text" $(x + 1) --- > something else|] --- --- Is like: --- --- > a x = " random \"text\" "++ show (x + 1) ++"\n something else" -here :: QuasiQuoter -here = QuasiQuoter - {quoteExp = hereExpQ - ,quotePat = herePatQ} - -instance Lift Here - where lift = liftHere - -liftHere :: Here -> ExpQ -liftHere (TextH s) = (litE . stringL) s -liftHere (CodeH e) = [|show $(return e)|] -liftHere (ManyH hs) = [|concat $(listE (fmap liftHere hs))|] - - -hereExpQ :: String -> ExpQ -hereExpQ s = case run s of - [] -> fail "here: parse error" - e:_ -> lift (cleanNames e) - -herePatQ :: String -> PatQ -herePatQ s = do - e <- hereExpQ s - let p = (parsePat - . pprint - . cleanNames) e - case p of - Left e -> fail e - Right p -> return p - -run :: String -> [Here] -run = fst . parse - -parse :: String -> ([Here], String) -parse = runP hereP - -hereP :: ReadP Here -hereP = (ManyH . mergeTexts) - `fmap` many (oneP =<< look) - -mergeTexts :: [Here] -> [Here] -mergeTexts [] = [] -mergeTexts (TextH s:TextH t:hs) - = mergeTexts (TextH (s++t):hs) -mergeTexts (h:hs) = h : mergeTexts hs - -oneP :: String -> ReadP Here -oneP s - | [] <- s = pfail - | '\\':'$':s <- s = do skip 2 - (TextH . ("\\$"++)) - `fmap` munch (/='\\') - | '$':'(':s <- s = skip 2 >> go 1 [] s - | c:s <- s = do skip 1 - (TextH . (c:)) - `fmap` munch (not.(`elem`"\\$")) - where go _ acc [] = return (TextH (reverse acc)) - go 1 [] (')':_) = skip 1 >> return (TextH "$()") - go 1 acc (')':_) = do skip (1 + length acc) - let s = reverse acc - either (const (return - (TextH s))) - (return . CodeH) - (parseExp s) - go n acc ('(':s) = go (n+1) ('(':acc) s - go n acc (')':s) = go (n-1) (')':acc) s - go n acc (c:s) = go n (c:acc) s - - -runP :: ReadP a -> String -> ([a], String) -runP p s = case readP_to_S p s of - [] -> ([],[]) - xs -> mapfst (:[]) (last xs) - where mapfst f (a,b) = (f a,b) -skip :: Int -> ReadP () -skip n = count n get >> return () -lexemeP :: ReadP a -> ReadP a -lexemeP p = p >>= \x -> skipSpaces >> return x -nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a) -nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p) -parensP = between oparenP cparenP -bracksP = between oparenP cparenP -oparenP = char '(' -cparenP = char ')' -obrackP = char '[' -cbrackP = char ']' - +{-# 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 ']'+
examples/SKI.hs view
@@ -1,155 +1,155 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-} - -module Language.Haskell.Meta.QQ.SKI (SKI(..),ski) where - -import Language.Haskell.Meta (parseExp, parsePat) -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unQ) -import Text.ParserCombinators.ReadP -import Data.Typeable(Typeable) -import Data.Generics(Data) -import Text.PrettyPrint(render) - -data SKI = S | K | I | E Exp | SKI :$ SKI - deriving (Eq,Data,Typeable) - -run :: String -> [SKI] -run = fmap eval . fst . parse - --- I x = x --- K x y = x --- S x y z = (x z) (y z) -eval :: SKI -> SKI -eval (I :$ x) = eval x -eval ((K :$ x) :$ y) = eval x -eval (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z)) -eval (E e :$ E e') = E (unQ[|$(return e) $(return e')|]) -eval (x :$ y) = eval0 ((eval x) :$ (eval y)) -eval x = x -eval0 (I :$ x) = eval x -eval0 ((K :$ x) :$ y) = eval x -eval0 (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z)) -eval0 (E e :$ E e') = E (unQ[|$(return e) $(return e')|]) -eval0 x = x - -ski :: QuasiQuoter -ski = QuasiQuoter - {quoteExp = skiExpQ - ,quotePat = skiPatQ} - -instance Lift SKI where - lift = liftSKI - -liftSKI (E e) = return e -liftSKI a = go a - where go S = [|S|] - go K = [|K|] - go I = [|I|] - go (E e) = [|E e|] - go (x:$y) = [|$(go x) :$ $(go y)|] - -instance Show SKI where - showsPrec p (S) = showString "S" - showsPrec p (K) = showString "K" - showsPrec p (I) = showString "I" - showsPrec p (E x1) - = showParen (p > 10) - (showString (render (ppDoc x1))) - showsPrec p ((:$) x1 x2) - = showParen (p > 10) - (showsPrec 11 x1 . (showString " :$ " . showsPrec 10 x2)) - -skiExpQ :: String -> ExpQ -skiExpQ s = case run s of - [] -> fail "ski: parse error" - e:_ -> lift (cleanNames e) - -skiPatQ :: String -> PatQ -skiPatQ s = do - e <- skiExpQ s - let p = (parsePat - . pprint - . cleanNames) e - case p of - Left e -> fail e - Right p -> return p - --- ghci> parse "S(SS)IK(SK)" --- ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"") -parse :: String -> ([SKI], String) -parse = runP skiP - -skiP :: ReadP SKI -skiP = nestedP parensP - (let go a = (do b <- lexemeP (oneP <++ skiP) - go (a:$b)) <++ return a - in lexemeP (go =<< lexemeP oneP)) - -oneP :: ReadP SKI -oneP = nestedP parensP - (lexemeP (choice [sP - ,kP - ,iP - ,spliceP =<< look - ])) - -spliceP :: String -> ReadP SKI -spliceP s - | '[':s <- s = skip 1 >> go 1 [] s - | otherwise = pfail - where go _ _ [] = pfail - go 1 acc (']':_) = do skip (1 + length acc) - either (const pfail) - (return . E) - (parseExp (reverse acc)) - go n acc ('[':s) = go (n+1) ('[':acc) s - go n acc (']':s) = go (n-1) (']':acc) s - go n acc (c:s) = go n (c:acc) s - - - -sP = (char 's' +++ char 'S') >> return S -kP = (char 'k' +++ char 'K') >> return K -iP = (char 'i' +++ char 'I') >> return I - -runP :: ReadP a -> String -> ([a], String) -runP p s = case readP_to_S p s of - [] -> ([],[]) - xs -> mapfst (:[]) (last xs) - where mapfst f (a,b) = (f a,b) -skip :: Int -> ReadP () -skip n = count n get >> return () -lexemeP :: ReadP a -> ReadP a -lexemeP p = p >>= \x -> skipSpaces >> return x -nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a) -nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p) -parensP = between oparenP cparenP -bracksP = between oparenP cparenP -oparenP = char '(' -cparenP = char ')' -obrackP = char '[' -cbrackP = char ']' - - - - -{- -import Prelude hiding (($)) -data Komb = S (Maybe (Komb, Maybe Komb)) | K (Maybe Komb) deriving Show -S Nothing $ x = S (Just (x, Nothing)) -S (Just (x, Nothing)) $ y = S (Just (x, Just y)) -S (Just (x, Just y)) $ z = x $ z $ (y $ z) -K Nothing $ x = K (Just x) -K (Just x) $ y = y -q x = x $ (c $ k) $ k $ k $ s - where s = S Nothing - k = K Nothing - c = s $ (b $ b $ s) $ k $ k - b = s $ (k $ s) $ k --} - - - +{-# 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.cabal view
@@ -1,46 +1,46 @@-name: haskell-src-meta -version: 0.5 -cabal-version: >= 1.6 -build-type: Simple -license: BSD3 -license-file: LICENSE -category: Language -author: Matt Morrow -copyright: (c) Matt Morrow -maintainer: Ben Millwood <haskell@benmachine.co.uk> -bug-reports: https://github.com/benmachine/haskell-src-meta/issues -stability: experimental -tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.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: examples/*.hs README - -library - build-depends: base >= 4.2 && < 4.5, - haskell-src-exts >= 1.6 && < 1.12, - template-haskell >= 2.4 && < 2.7, - pretty >= 1.0 && < 1.2, - syb >= 0.1 && < 0.4, - th-lift == 0.5.* - 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.Syntax.Translate - Language.Haskell.TH.Instances.Lift - Language.Haskell.Meta.Utils - -source-repository head - type: git - location: git://github.com/benmachine/haskell-src-meta.git - +name: haskell-src-meta+version: 0.5.0.2+cabal-version: >= 1.6+build-type: Simple+license: BSD3+license-file: LICENSE+category: Language+author: Matt Morrow+copyright: (c) Matt Morrow+maintainer: Ben Millwood <haskell@benmachine.co.uk>+bug-reports: https://github.com/benmachine/haskell-src-meta/issues+stability: experimental+tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.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: examples/*.hs README++library+ build-depends: base >= 4.2 && < 4.5,+ haskell-src-exts >= 1.6 && < 1.12,+ template-haskell >= 2.4 && < 2.7,+ pretty >= 1.0 && < 1.2,+ syb >= 0.1 && < 0.4,+ th-lift == 0.5.*+ 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.Syntax.Translate+ Language.Haskell.TH.Instances.Lift+ Language.Haskell.Meta.Utils++source-repository head+ type: git+ location: git://github.com/benmachine/haskell-src-meta.git+
src/Language/Haskell/Meta.hs view
@@ -1,18 +1,18 @@- -{- | - Module : Language.Haskell.Meta - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow <mjm2002@gmail.com> - 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.Lift() ++{- |+ Module : Language.Haskell.Meta+ Copyright : (c) Matt Morrow 2008+ License : BSD3+ Maintainer : Matt Morrow <mjm2002@gmail.com>+ 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.Lift()
src/Language/Haskell/Meta/Parse.hs view
@@ -1,163 +1,163 @@-{- | - Module : Language.Haskell.Meta.Parse - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow <mjm2002@gmail.com> - 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 - -import Language.Haskell.TH.Syntax -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 = [] - ,extensions = myDefaultExtensions - ,ignoreLinePragmas = False - ,ignoreLanguagePragmas = False - ,fixities = defaultFixities} - --- This is a silly hack to make things work on haskell-src-exts versions --- 1.10 and 1.11 simultaneously. I justify it because myDefaultParseMode is --- deprecated anyway. --- --- Essentially we want defaultFixities to be baseFixities or Just baseFixities --- as appropriate. We do this without requiring FlexibleInstances using the --- same trick as Show on lists does. -class DefaultFixities a where - defaultFixities :: a - defaultFixities = - error "Language.Haskell.Meta.Parse.defaultFixities undefined" - defaultFixityList :: [a] - defaultFixityList = - error "Language.Haskell.Meta.Parse.defaultFixityList undefined" - -instance DefaultFixities Fix.Fixity where - defaultFixityList = baseFixities - -instance DefaultFixities a => DefaultFixities [a] where - defaultFixities = defaultFixityList - -instance DefaultFixities a => DefaultFixities (Maybe a) where - defaultFixities = Just defaultFixities - -myDefaultExtensions :: [Extension] -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 --} - ------------------------------------------------------------------------------ +{- |+ Module : Language.Haskell.Meta.Parse+ Copyright : (c) Matt Morrow 2008+ License : BSD3+ Maintainer : Matt Morrow <mjm2002@gmail.com>+ 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++import Language.Haskell.TH.Syntax+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 = []+ ,extensions = myDefaultExtensions+ ,ignoreLinePragmas = False+ ,ignoreLanguagePragmas = False+ ,fixities = defaultFixities}++-- This is a silly hack to make things work on haskell-src-exts versions+-- 1.10 and 1.11 simultaneously. I justify it because myDefaultParseMode is+-- deprecated anyway.+--+-- Essentially we want defaultFixities to be baseFixities or Just baseFixities+-- as appropriate. We do this without requiring FlexibleInstances using the+-- same trick as Show on lists does.+class DefaultFixities a where+ defaultFixities :: a+ defaultFixities =+ error "Language.Haskell.Meta.Parse.defaultFixities undefined"+ defaultFixityList :: [a]+ defaultFixityList =+ error "Language.Haskell.Meta.Parse.defaultFixityList undefined"++instance DefaultFixities Fix.Fixity where+ defaultFixityList = baseFixities++instance DefaultFixities a => DefaultFixities [a] where+ defaultFixities = defaultFixityList++instance DefaultFixities a => DefaultFixities (Maybe a) where+ defaultFixities = Just defaultFixities++myDefaultExtensions :: [Extension]+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+-}++-----------------------------------------------------------------------------
src/Language/Haskell/Meta/Syntax/Translate.hs view
@@ -1,652 +1,656 @@-{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-} - -{- | - Module : Language.Haskell.Meta.Syntax.Translate - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow <mjm2002@gmail.com> - Stability : experimental - Portability : portable (template-haskell) --} - -module Language.Haskell.Meta.Syntax.Translate ( - module Language.Haskell.Meta.Syntax.Translate -) where - -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 - --- 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, - ": no TH 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 toName . 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 - - - ------------------------------------------------------------------------------ - --- * 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 (Hs.PrimChar a) = CharL a -- XXX - toLit (Hs.PrimString a) = StringL a -- XXX - toLit (Hs.PrimInt a) = IntPrimL a - toLit (Hs.PrimFloat a) = FloatPrimL a - toLit (Hs.PrimDouble a) = DoublePrimL a -#if MIN_VERSION_template_haskell(2,4,0) - toLit (Hs.PrimWord a) = WordPrimL a -#endif /* MIN_VERSION_template_haskell(2,4,0) */ - - ------------------------------------------------------------------------------ - --- * ToPat HsPat - - -instance ToPat Hs.Pat where - toPat (Hs.PVar n) - = VarP (toName n) - toPat (Hs.PLit l) - = LitP (toLit l) -{- -ghci> parseHsPat "-2" -Right (HsPParen (HsPNeg (HsPLit (HsInt 2)))) --} - toPat (Hs.PNeg (Hs.PLit 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.PNeg p) = nonsense "toPat" "negating non-literal" p - toPat (Hs.PInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q) - toPat (Hs.PApp n ps) = ConP (toName n) (fmap toPat ps) - toPat (Hs.PTuple ps) = TupP (fmap toPat ps) - toPat (Hs.PList ps) = ListP (fmap toPat ps) - toPat (Hs.PParen p) = 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) - -- 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 -#if MIN_VERSION_template_haskell(2,4,0) - toPat (Hs.PBangPat p) = BangP (toPat p) -#endif /* MIN_VERSION_template_haskell(2,4,0) */ - ------------------------------------------------------------------------------ - --- * 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 -{- -data HsExp - = HsVar HsQName --} --- | HsIPVar HsIPName -{- - | HsLet HsBinds HsExp - | HsDLet [HsIPBind] HsExp - | HsWith HsExp [HsIPBind] - | HsCase HsExp [HsAlt] - | HsDo [HsStmt] - -- use mfix somehow - | HsMDo [HsStmt] --} - toExp (Hs.Var n) = VarE (toName n) - toExp (Hs.Con n) = ConE (toName n) - toExp (Hs.Lit l) = LitE (toLit l) - toExp (Hs.InfixApp e o f) = InfixE (Just . toExp $ e) (toExp o) (Just . toExp $ f) - 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.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 (hsBindsToDecs bs) (toExp e) - -- toExp (HsWith e bs - toExp (Hs.If a b c) = CondE (toExp a) (toExp b) (toExp c) - toExp (Hs.Do ss) = DoE (map toStmt ss) - -- toExp (HsMDo ss) - toExp (Hs.Tuple xs) = TupE (fmap toExp xs) - toExp (Hs.List xs) = ListE (fmap toExp xs) - toExp (Hs.Paren e) = toExp e - 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.ExpTypeSig _ e t) = SigE (toExp e) (toType t) - -- HsListComp HsExp [HsStmt] - -- toExp (HsListComp e ss) = CompE - -- NEED: a way to go e -> Stmt -{- HsVarQuote HsQName - | HsTypQuote HsQName - | HsBracketExp HsBracket - | HsSpliceExp HsSplice -data HsBracket - = HsExpBracket HsExp - | HsPatBracket HsPat - | HsTypeBracket HsType - | HsDeclBracket [HsDecl] -data HsSplice = HsIdSplice String | HsParenSplice HsExp -} - toExp (Hs.Case e alts) = CaseE (toExp e) (map toMatch alts) - toExp e = todo "toExp" e - - -toMatch :: Hs.Alt -> Match -toMatch (Hs.Alt _ p galts ds) = Match (toPat p) (toBody galts) (toDecs ds) - -toBody :: Hs.GuardedAlts -> Body -toBody (Hs.UnGuardedAlt e) = NormalB $ toExp e -toBody (Hs.GuardedAlts alts) = GuardedB $ do - Hs.GuardedAlt _ stmts e <- alts - let - g = case map toStmt stmts of - [NoBindS x] -> NormalG x - xs -> PatG xs - return (g, toExp e) - -toGuard (Hs.GuardedAlt _ ([Hs.Qualifier e1]) e2) = (NormalG $ toExp e1,toExp e2) - ------------------------------------------------------------------------------ - -{- -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 ToDec a where toDec :: a -> Dec -class ToStmt a where toStmt :: a -> Stmt -class ToLoc a where toLoc :: a -> Loc --} - -{- -TODO: - [] - -PARTIAL: - * ToExp HsExp - * ToStmt HsStmt - * ToDec HsDecl - -DONE: - * ToLit HsLiteral - * ToName {..} - * ToPat HsPat - * ToLoc SrcLoc - * ToType HsType - --} ------------------------------------------------------------------------------ - --- * 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 - -#if MIN_VERSION_template_haskell(2,4,0) -instance ToName TyVarBndr where - toName (PlainTV n) = n - toName (KindedTV n _) = n -#endif /* !MIN_VERSION_template_haskell(2,4,0) */ - -#if MIN_VERSION_template_haskell(2,4,0) -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{} = noTH "toKind" k -#endif /* !MIN_VERSION_template_haskell(2,4,0) */ - -#if MIN_VERSION_template_haskell(2,4,0) -toTyVar :: Hs.TyVarBind -> TyVarBndr -toTyVar (Hs.KindedVar n k) = KindedTV (toName n) (toKind k) -toTyVar (Hs.UnkindedVar n) = PlainTV (toName n) -#else /* !MIN_VERSION_template_haskell(2,4,0) */ -toTyVar :: Hs.TyVarBind -> Name -toTyVar (Hs.KindedVar n _) = toName n -toTyVar (Hs.UnkindedVar n) = toName n -#endif /* !MIN_VERSION_template_haskell(2,4,0) */ - -{- | -TH does't handle - * unboxed tuples - * implicit params - * infix type constructors - * kind signatures --} -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 _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts) - 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 _) = toType t - - - - -(.->.) :: Type -> Type -> Type -a .->. b = AppT (AppT ArrowT a) b - -{- | -TH doesn't handle: - * implicit params --} - -toCxt :: Hs.Context -> Cxt -toCxt = fmap toPred - where -#if MIN_VERSION_template_haskell(2,4,0) - 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) - toPred a@Hs.IParam{} = noTH "toCxt" a -#else /* !MIN_VERSION_template_haskell(2,4,0) */ - toPred (Hs.ClassA n ts) = foldAppT (ConT (toName n)) (fmap toType ts) - toPred (Hs.InfixA t1 n t2) = foldAppT (ConT (toName n)) (fmap toType [t1, t2]) - toPred a@Hs.EqualP{} = noTH "toCxt" a - toPred a@Hs.IParam{} = noTH "toCxt" a -#endif /* !MIN_VERSION_template_haskell(2,4,0) */ - -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 (hsBindsToDecs bnds) - - ------------------------------------------------------------------------------ - --- * ToDec HsDecl - --- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind] -hsBindsToDecs :: Hs.Binds -> [Dec] -hsBindsToDecs (Hs.BDecls ds) = fmap toDec ds -hsBindsToDecs a@Hs.IPBinds{} = noTH "hsBindsToDecs" a --- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp - - -hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type) -hsBangTypeToStrictType (Hs.BangedTy t) = (IsStrict, toType t) -hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t) - - -{- -data HsTyVarBind = HsKindedVar HsName HsKind | HsUnkindedVar HsName -data HsConDecl - = HsConDecl HsName [HsBangType] - | HsRecDecl HsName [([HsName], HsBangType)] --} -{- -hsQualConDeclToCon :: HsQualConDecl -> Con -hsQualConDeclToCon (HsQualConDecl _ tvbs cxt condec) = - case condec of - HsConDecl n bangs -> - HsRecDecl n assocs -> --} - - - - -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) - (fmap qualConDeclToCon qcds) - (fmap (toName . fst) qns) - Hs.NewType -> let qcd = case qcds of - [x] -> x - _ -> nonsense "toDec" ("newtype with " ++ - "wrong number of constructors") dOrN - in NewtypeD (toCxt cxt) - (toName n) - (fmap toTyVar ns) - (qualConDeclToCon qcd) - (fmap (toName . fst) qns) - --- data Hs.BangType --- = Hs.BangedTy Hs.Type --- | Hs.UnBangedTy Hs.Type --- | Hs.UnpackedTy Hs.Type --- data Hs.TyVarBind --- = Hs.KindedVar Hs.Name Hs.Kind | Hs.UnkindedVar Hs.Name --- data Hs.DataOrNew = Hs.DataType | Hs.NewType --- data Hs.QualConDecl --- = Hs.QualConDecl Hs.SrcLoc [Hs.TyVarBind] Hs.Context Hs.ConDecl --- data Hs.ConDecl --- = Hs.ConDecl Hs.Name [Hs.BangType] --- | Hs.RecDecl Hs.Name [([Hs.Name], Hs.BangType)] - --- data Con --- = NormalC Name [StrictType] --- | RecC Name [VarStrictType] --- | InfixC StrictType Name StrictType --- | ForallC [Name] Cxt Con --- type StrictType = (Strict, Type) --- type VarStrictType = (Name, Strict, Type) - - - -- 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,4,0) - toDec (Hs.InlineConlikeSig _ act id) = PragmaD $ - InlineP (toName id) (InlineSpec True True $ transAct act) - toDec (Hs.InlineSig _ b act id) = PragmaD $ - InlineP (toName id) (InlineSpec b False $ transAct act) -#endif /* MIN_VERSION_template_haskell(2,4,0) */ - -{- data HsDecl = ... | HsFunBind [HsMatch] | ... -data HsMatch = HsMatch SrcLoc HsName [HsPat] HsRhs HsBinds -data Dec = FunD Name [Clause] | ... -data Clause = Clause [Pat] Body [Dec] -} - toDec a@(Hs.FunBind mtchs) = hsMatchesToFunD mtchs -{- ghci> parseExp "let x = 2 in x" -LetE [ValD (VarP x) (NormalB (LitE (IntegerL 2))) []] (VarE x) -ghci> unQ[| let x = 2 in x |] -LetE [ValD (VarP x_0) (NormalB (LitE (IntegerL 2))) []] (VarE x_0) -} - toDec (Hs.PatBind _ p tM rhs bnds) = ValD ((maybe id - (flip SigP . toType) - tM) (toPat p)) - (hsRhsToBody rhs) - (hsBindsToDecs bnds) - - toDec (Hs.InstDecl _ cxt qname ts ids) = InstanceD - (toCxt cxt) - (foldl AppT (ConT (toName qname)) (map toType ts)) - (toDecs ids) - - toDec x = todo "toDec" x - - --- data Hs.Decl = ... | Hs.SpliceDecl Hs.SrcLoc Hs.Splice | ... --- data Hs.Splice = Hs.IdSplice String | Hs.ParenSplice Hs.Exp - -transAct act = case act of - Hs.AlwaysActive -> Nothing - Hs.ActiveFrom n -> Just (True,n) - Hs.ActiveUntil n -> Just (False,n) - - - - - - - - -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) (fmap bangToStrictType tys) -conDeclToCon (Hs.RecDecl n lbls) - = RecC (toName n) (concatMap (uncurry bangToVarStrictTypes) lbls) - - - -bangToVarStrictTypes :: [Hs.Name] -> Hs.BangType -> [VarStrictType] -bangToVarStrictTypes ns t = let (a,b) = bangToStrictType t - in fmap (\n->(toName n,a,b)) ns - -bangToStrictType :: Hs.BangType -> StrictType -bangToStrictType (Hs.BangedTy t) = (IsStrict, toType t) -bangToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t) -bangToStrictType (Hs.UnpackedTy t) = (IsStrict, toType t) - - -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) - (hsBindsToDecs bnds) - - - --- data HsRhs = HsUnGuardedRhs HsExp | HsGuardedRhs [HsGuardedRhs] --- data HsGuardedRhs = HsGuardedRhs SrcLoc [HsStmt] HsExp --- data Body = GuardedB [(Guard, Exp)] | NormalB Exp --- data Guard = NormalG Exp | PatG [Stmt] -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 (hsBindsToDecs 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.InfixDecl _ asst i ops) = [] -- HACK --- toDecs (Hs.InlineSig _ _ _ _) = [] -- HACK - toDecs a@(Hs.TypeSig _ ns t) - = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns - in xs - - - toDecs a = [toDec a] - -collectVars e = case e of -#if MIN_VERSION_template_haskell(2,4,0) - VarT n -> [PlainTV n] -#else /* !MIN_VERSION_template_haskell(2,4,0) */ - VarT n -> [n] -#endif /* !MIN_VERSION_template_haskell(2,4,0) */ - 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 - - ------------------------------------------------------------------------------ +{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}++{- |+ Module : Language.Haskell.Meta.Syntax.Translate+ Copyright : (c) Matt Morrow 2008+ License : BSD3+ Maintainer : Matt Morrow <mjm2002@gmail.com>+ Stability : experimental+ Portability : portable (template-haskell)+-}++module Language.Haskell.Meta.Syntax.Translate (+ module Language.Haskell.Meta.Syntax.Translate+) where++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++-- 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,+ ": no TH 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++++-----------------------------------------------------------------------------++-- * 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 (Hs.PrimChar a) = CharL a -- XXX+#if MIN_VERSION_template_haskell(2,5,0)+ toLit (Hs.PrimString a) = StringPrimL a+#else /* MIN_VERSION_template_haskell(2,5,0) */+ toLit (Hs.PrimString a) = StringL a -- XXX+#endif /* MIN_VERSION_template_haskell(2,5,0) */+ toLit (Hs.PrimInt a) = IntPrimL a+ toLit (Hs.PrimFloat a) = FloatPrimL a+ toLit (Hs.PrimDouble a) = DoublePrimL a+#if MIN_VERSION_template_haskell(2,4,0)+ toLit (Hs.PrimWord a) = WordPrimL a+#endif /* MIN_VERSION_template_haskell(2,4,0) */+++-----------------------------------------------------------------------------++-- * ToPat HsPat+++instance ToPat Hs.Pat where+ toPat (Hs.PVar n)+ = VarP (toName n)+ toPat (Hs.PLit l)+ = LitP (toLit l)+{-+ghci> parseHsPat "-2"+Right (HsPParen (HsPNeg (HsPLit (HsInt 2))))+-}+ toPat (Hs.PNeg (Hs.PLit 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.PNeg p) = nonsense "toPat" "negating non-literal" p+ toPat (Hs.PInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q)+ toPat (Hs.PApp n ps) = ConP (toName n) (fmap toPat ps)+ toPat (Hs.PTuple ps) = TupP (fmap toPat ps)+ toPat (Hs.PList ps) = ListP (fmap toPat ps)+ toPat (Hs.PParen p) = 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)+ -- 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+#if MIN_VERSION_template_haskell(2,4,0)+ toPat (Hs.PBangPat p) = BangP (toPat p)+#endif /* MIN_VERSION_template_haskell(2,4,0) */++-----------------------------------------------------------------------------++-- * 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+{-+data HsExp+ = HsVar HsQName+-}+-- | HsIPVar HsIPName+{-+ | HsLet HsBinds HsExp+ | HsDLet [HsIPBind] HsExp+ | HsWith HsExp [HsIPBind]+ | HsCase HsExp [HsAlt]+ | HsDo [HsStmt]+ -- use mfix somehow+ | HsMDo [HsStmt]+-}+ toExp (Hs.Var n) = VarE (toName n)+ toExp (Hs.Con n) = ConE (toName n)+ toExp (Hs.Lit l) = LitE (toLit l)+ toExp (Hs.InfixApp e o f) = InfixE (Just . toExp $ e) (toExp o) (Just . toExp $ f)+ 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.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 (hsBindsToDecs bs) (toExp e)+ -- toExp (HsWith e bs+ toExp (Hs.If a b c) = CondE (toExp a) (toExp b) (toExp c)+ toExp (Hs.Do ss) = DoE (map toStmt ss)+ -- toExp (HsMDo ss)+ toExp (Hs.Tuple xs) = TupE (fmap toExp xs)+ toExp (Hs.List xs) = ListE (fmap toExp xs)+ toExp (Hs.Paren e) = toExp e+ 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.ExpTypeSig _ e t) = SigE (toExp e) (toType t)+ -- HsListComp HsExp [HsStmt]+ -- toExp (HsListComp e ss) = CompE+ -- NEED: a way to go e -> Stmt+{- HsVarQuote HsQName+ | HsTypQuote HsQName+ | HsBracketExp HsBracket+ | HsSpliceExp HsSplice+data HsBracket+ = HsExpBracket HsExp+ | HsPatBracket HsPat+ | HsTypeBracket HsType+ | HsDeclBracket [HsDecl]+data HsSplice = HsIdSplice String | HsParenSplice HsExp -}+ toExp (Hs.Case e alts) = CaseE (toExp e) (map toMatch alts)+ toExp e = todo "toExp" e+++toMatch :: Hs.Alt -> Match+toMatch (Hs.Alt _ p galts ds) = Match (toPat p) (toBody galts) (toDecs ds)++toBody :: Hs.GuardedAlts -> Body+toBody (Hs.UnGuardedAlt e) = NormalB $ toExp e+toBody (Hs.GuardedAlts alts) = GuardedB $ do+ Hs.GuardedAlt _ stmts e <- alts+ let+ g = case map toStmt stmts of+ [NoBindS x] -> NormalG x+ xs -> PatG xs+ return (g, toExp e)++toGuard (Hs.GuardedAlt _ ([Hs.Qualifier e1]) e2) = (NormalG $ toExp e1,toExp e2)++-----------------------------------------------------------------------------++{-+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 ToDec a where toDec :: a -> Dec+class ToStmt a where toStmt :: a -> Stmt+class ToLoc a where toLoc :: a -> Loc+-}++{-+TODO:+ []++PARTIAL:+ * ToExp HsExp+ * ToStmt HsStmt+ * ToDec HsDecl++DONE:+ * ToLit HsLiteral+ * ToName {..}+ * ToPat HsPat+ * ToLoc SrcLoc+ * ToType HsType++-}+-----------------------------------------------------------------------------++-- * 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++#if MIN_VERSION_template_haskell(2,4,0)+instance ToName TyVarBndr where+ toName (PlainTV n) = n+ toName (KindedTV n _) = n+#endif /* !MIN_VERSION_template_haskell(2,4,0) */++#if MIN_VERSION_template_haskell(2,4,0)+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{} = noTH "toKind" k+#endif /* !MIN_VERSION_template_haskell(2,4,0) */++#if MIN_VERSION_template_haskell(2,4,0)+toTyVar :: Hs.TyVarBind -> TyVarBndr+toTyVar (Hs.KindedVar n k) = KindedTV (toName n) (toKind k)+toTyVar (Hs.UnkindedVar n) = PlainTV (toName n)+#else /* !MIN_VERSION_template_haskell(2,4,0) */+toTyVar :: Hs.TyVarBind -> Name+toTyVar (Hs.KindedVar n _) = toName n+toTyVar (Hs.UnkindedVar n) = toName n+#endif /* !MIN_VERSION_template_haskell(2,4,0) */++{- |+TH does't handle+ * unboxed tuples+ * implicit params+ * infix type constructors+ * kind signatures+-}+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 _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts)+ 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 _) = toType t+++++(.->.) :: Type -> Type -> Type+a .->. b = AppT (AppT ArrowT a) b++{- |+TH doesn't handle:+ * implicit params+-}++toCxt :: Hs.Context -> Cxt+toCxt = fmap toPred+ where+#if MIN_VERSION_template_haskell(2,4,0)+ 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)+ toPred a@Hs.IParam{} = noTH "toCxt" a+#else /* !MIN_VERSION_template_haskell(2,4,0) */+ toPred (Hs.ClassA n ts) = foldAppT (ConT (toName n)) (fmap toType ts)+ toPred (Hs.InfixA t1 n t2) = foldAppT (ConT (toName n)) (fmap toType [t1, t2])+ toPred a@Hs.EqualP{} = noTH "toCxt" a+ toPred a@Hs.IParam{} = noTH "toCxt" a+#endif /* !MIN_VERSION_template_haskell(2,4,0) */++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 (hsBindsToDecs bnds)+++-----------------------------------------------------------------------------++-- * ToDec HsDecl++-- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind]+hsBindsToDecs :: Hs.Binds -> [Dec]+hsBindsToDecs (Hs.BDecls ds) = fmap toDec ds+hsBindsToDecs a@Hs.IPBinds{} = noTH "hsBindsToDecs" a+-- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp+++hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type)+hsBangTypeToStrictType (Hs.BangedTy t) = (IsStrict, toType t)+hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)+++{-+data HsTyVarBind = HsKindedVar HsName HsKind | HsUnkindedVar HsName+data HsConDecl+ = HsConDecl HsName [HsBangType]+ | HsRecDecl HsName [([HsName], HsBangType)]+-}+{-+hsQualConDeclToCon :: HsQualConDecl -> Con+hsQualConDeclToCon (HsQualConDecl _ tvbs cxt condec) =+ case condec of+ HsConDecl n bangs ->+ HsRecDecl n assocs ->+-}+++++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)+ (fmap qualConDeclToCon qcds)+ (fmap (toName . fst) qns)+ Hs.NewType -> let qcd = case qcds of+ [x] -> x+ _ -> nonsense "toDec" ("newtype with " +++ "wrong number of constructors") dOrN+ in NewtypeD (toCxt cxt)+ (toName n)+ (fmap toTyVar ns)+ (qualConDeclToCon qcd)+ (fmap (toName . fst) qns)++-- data Hs.BangType+-- = Hs.BangedTy Hs.Type+-- | Hs.UnBangedTy Hs.Type+-- | Hs.UnpackedTy Hs.Type+-- data Hs.TyVarBind+-- = Hs.KindedVar Hs.Name Hs.Kind | Hs.UnkindedVar Hs.Name+-- data Hs.DataOrNew = Hs.DataType | Hs.NewType+-- data Hs.QualConDecl+-- = Hs.QualConDecl Hs.SrcLoc [Hs.TyVarBind] Hs.Context Hs.ConDecl+-- data Hs.ConDecl+-- = Hs.ConDecl Hs.Name [Hs.BangType]+-- | Hs.RecDecl Hs.Name [([Hs.Name], Hs.BangType)]++-- data Con+-- = NormalC Name [StrictType]+-- | RecC Name [VarStrictType]+-- | InfixC StrictType Name StrictType+-- | ForallC [Name] Cxt Con+-- type StrictType = (Strict, Type)+-- type VarStrictType = (Name, Strict, Type)+++ -- 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,4,0)+ toDec (Hs.InlineConlikeSig _ act id) = PragmaD $ + InlineP (toName id) (InlineSpec True True $ transAct act)+ toDec (Hs.InlineSig _ b act id) = PragmaD $ + InlineP (toName id) (InlineSpec b False $ transAct act)+#endif /* MIN_VERSION_template_haskell(2,4,0) */++{- data HsDecl = ... | HsFunBind [HsMatch] | ...+data HsMatch = HsMatch SrcLoc HsName [HsPat] HsRhs HsBinds+data Dec = FunD Name [Clause] | ...+data Clause = Clause [Pat] Body [Dec] -}+ toDec a@(Hs.FunBind mtchs) = hsMatchesToFunD mtchs+{- ghci> parseExp "let x = 2 in x"+LetE [ValD (VarP x) (NormalB (LitE (IntegerL 2))) []] (VarE x)+ghci> unQ[| let x = 2 in x |]+LetE [ValD (VarP x_0) (NormalB (LitE (IntegerL 2))) []] (VarE x_0) -}+ toDec (Hs.PatBind _ p tM rhs bnds) = ValD ((maybe id+ (flip SigP . toType)+ tM) (toPat p))+ (hsRhsToBody rhs)+ (hsBindsToDecs bnds)++ toDec (Hs.InstDecl _ cxt qname ts ids) = InstanceD + (toCxt cxt) + (foldl AppT (ConT (toName qname)) (map toType ts))+ (toDecs ids)+ + toDec x = todo "toDec" x+++-- data Hs.Decl = ... | Hs.SpliceDecl Hs.SrcLoc Hs.Splice | ...+-- data Hs.Splice = Hs.IdSplice String | Hs.ParenSplice Hs.Exp++transAct act = case act of+ Hs.AlwaysActive -> Nothing+ Hs.ActiveFrom n -> Just (True,n)+ Hs.ActiveUntil n -> Just (False,n)+++++++++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) (fmap bangToStrictType tys)+conDeclToCon (Hs.RecDecl n lbls)+ = RecC (toName n) (concatMap (uncurry bangToVarStrictTypes) lbls)++++bangToVarStrictTypes :: [Hs.Name] -> Hs.BangType -> [VarStrictType]+bangToVarStrictTypes ns t = let (a,b) = bangToStrictType t+ in fmap (\n->(toName n,a,b)) ns++bangToStrictType :: Hs.BangType -> StrictType+bangToStrictType (Hs.BangedTy t) = (IsStrict, toType t)+bangToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)+bangToStrictType (Hs.UnpackedTy t) = (IsStrict, toType t)+++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)+ (hsBindsToDecs bnds)++++-- data HsRhs = HsUnGuardedRhs HsExp | HsGuardedRhs [HsGuardedRhs]+-- data HsGuardedRhs = HsGuardedRhs SrcLoc [HsStmt] HsExp+-- data Body = GuardedB [(Guard, Exp)] | NormalB Exp+-- data Guard = NormalG Exp | PatG [Stmt]+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 (hsBindsToDecs 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.InfixDecl _ asst i ops) = [] -- HACK+-- toDecs (Hs.InlineSig _ _ _ _) = [] -- HACK+ toDecs a@(Hs.TypeSig _ ns t)+ = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns+ in xs+++ toDecs a = [toDec a]++collectVars e = case e of+#if MIN_VERSION_template_haskell(2,4,0)+ VarT n -> [PlainTV n]+#else /* !MIN_VERSION_template_haskell(2,4,0) */+ VarT n -> [n]+#endif /* !MIN_VERSION_template_haskell(2,4,0) */+ 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+++-----------------------------------------------------------------------------
src/Language/Haskell/Meta/Utils.hs view
@@ -1,522 +1,522 @@-{-# 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.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.Lift (deriveLift) -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 . unQ -instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unQ -instance Show DecQ where show = show . cleanNames . unQ -instance Show TypeQ where show = show . cleanNames . unQ -instance Show (Q String) where show = unQ -instance Show (Q Doc) where show = show . unQ - -deriving instance Typeable1 Q -deriving instance Typeable QuasiQuoter - - --- | @unQ = unsafePerformIO . runQ@ -unQ :: Q a -> a -unQ = 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 -#if MIN_VERSION_template_haskell(2,4,0) - unVarT (VarT n) = PlainTV n - renamePreds = renameThings renamePred - - 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) - -#else /* !MIN_VERSION_template_haskell(2,4,0) */ - unVarT (VarT n) = n - renamePreds = renameTs - -#endif /* !MIN_VERSION_template_haskell(2,4,0) */ - --- | 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 - - - - - --- | Produces pretty code suitable --- for human consumption. -deriveLiftPretty :: Name -> Q String -deriveLiftPretty n = do - decs <- deriveLift n - case (parseHsDecls . pprint . cleanNames) decs of - Left e -> fail ("deriveLiftPretty: error while prettifying code: "++e) - Right hsdecs -> return (unlines . fmap prettyPrint $ hsdecs) - - - -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] -decCons (DataD _ _ _ cons _) = cons -decCons (NewtypeD _ _ _ con _) = [con] -decCons _ = [] - - -#if MIN_VERSION_template_haskell(2,4,0) -decTyVars :: Dec -> [TyVarBndr] -#else /* !MIN_VERSION_template_haskell(2,4,0) */ -decTyVars :: Dec -> [Name] -#endif /* !MIN_VERSION_template_haskell(2,4,0) */ -decTyVars (DataD _ _ ns _ _) = ns -decTyVars (NewtypeD _ _ ns _ _) = ns -decTyVars (TySynD _ ns _) = ns -decTyVars (ClassD _ _ ns _ _) = ns -decTyVars _ = [] - - -decName :: Dec -> Maybe Name -decName (FunD n _) = Just n -decName (DataD _ n _ _ _) = Just n -decName (NewtypeD _ n _ _ _) = Just n -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] -dataDCons (DataD _ _ _ cons _) = cons -dataDCons _ = [] - -fromDataConI :: Info -> Q (Maybe Exp) -fromDataConI (DataConI dConN ty tyConN fxty) = - 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) | n == ''(,) = TupleT 2 - go (ConT n) | n == ''(,,) = TupleT 3 - go (ConT n) | n == ''(,,,) = TupleT 4 - go (ConT n) | n == ''(,,,,) = TupleT 5 - go (ConT n) | n == ''(,,,,,) = TupleT 6 - go (ConT n) | n == ''(,,,,,,) = TupleT 7 - go (ConT n) | n == ''(,,,,,,,) = TupleT 8 - go (ConT n) | n == ''(,,,,,,,,) = TupleT 9 - go (ConT n) | n == ''(,,,,,,,,,) = TupleT 10 - go (ConT n) | n == ''(,,,,,,,,,,) = TupleT 11 - go (ConT n) | n == ''(,,,,,,,,,,,) = TupleT 12 - go (ConT n) | n == ''(,,,,,,,,,,,,) = TupleT 13 - go (ConT n) | n == ''(,,,,,,,,,,,,,) = TupleT 14 - go (ConT n) | n == ''(,,,,,,,,,,,,,,) = TupleT 15 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,) = TupleT 16 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,) = TupleT 17 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,) = TupleT 18 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,) = TupleT 19 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,) = TupleT 20 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,) = TupleT 21 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,) = TupleT 22 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,) = TupleT 23 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 24 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 25 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 26 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 27 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 28 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 29 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 30 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 31 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 32 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 33 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 34 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 35 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 36 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 37 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 38 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 39 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 40 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 41 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 42 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 43 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 44 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 45 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 46 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 47 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 48 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 49 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 50 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 51 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 52 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 53 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 54 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 55 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 56 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 57 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 58 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 59 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 60 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 61 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 62 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 63 - go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 64 - go t = t - - - ------------------------------------------------------------------------------ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +{-# 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.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.Lift (deriveLift)+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 . unQ+instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unQ+instance Show DecQ where show = show . cleanNames . unQ+instance Show TypeQ where show = show . cleanNames . unQ+instance Show (Q String) where show = unQ+instance Show (Q Doc) where show = show . unQ++deriving instance Typeable1 Q+deriving instance Typeable QuasiQuoter+++-- | @unQ = unsafePerformIO . runQ@+unQ :: Q a -> a+unQ = 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+#if MIN_VERSION_template_haskell(2,4,0)+ unVarT (VarT n) = PlainTV n+ renamePreds = renameThings renamePred++ 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)++#else /* !MIN_VERSION_template_haskell(2,4,0) */+ unVarT (VarT n) = n+ renamePreds = renameTs++#endif /* !MIN_VERSION_template_haskell(2,4,0) */++-- | 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++++++-- | Produces pretty code suitable+-- for human consumption.+deriveLiftPretty :: Name -> Q String+deriveLiftPretty n = do+ decs <- deriveLift n+ case (parseHsDecls . pprint . cleanNames) decs of+ Left e -> fail ("deriveLiftPretty: error while prettifying code: "++e)+ Right hsdecs -> return (unlines . fmap prettyPrint $ hsdecs)++++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]+decCons (DataD _ _ _ cons _) = cons+decCons (NewtypeD _ _ _ con _) = [con]+decCons _ = []+++#if MIN_VERSION_template_haskell(2,4,0)+decTyVars :: Dec -> [TyVarBndr]+#else /* !MIN_VERSION_template_haskell(2,4,0) */+decTyVars :: Dec -> [Name]+#endif /* !MIN_VERSION_template_haskell(2,4,0) */+decTyVars (DataD _ _ ns _ _) = ns+decTyVars (NewtypeD _ _ ns _ _) = ns+decTyVars (TySynD _ ns _) = ns+decTyVars (ClassD _ _ ns _ _) = ns+decTyVars _ = []+++decName :: Dec -> Maybe Name+decName (FunD n _) = Just n+decName (DataD _ n _ _ _) = Just n+decName (NewtypeD _ n _ _ _) = Just n+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]+dataDCons (DataD _ _ _ cons _) = cons+dataDCons _ = []++fromDataConI :: Info -> Q (Maybe Exp)+fromDataConI (DataConI dConN ty tyConN fxty) =+ 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) | n == ''(,) = TupleT 2+ go (ConT n) | n == ''(,,) = TupleT 3+ go (ConT n) | n == ''(,,,) = TupleT 4+ go (ConT n) | n == ''(,,,,) = TupleT 5+ go (ConT n) | n == ''(,,,,,) = TupleT 6+ go (ConT n) | n == ''(,,,,,,) = TupleT 7+ go (ConT n) | n == ''(,,,,,,,) = TupleT 8+ go (ConT n) | n == ''(,,,,,,,,) = TupleT 9+ go (ConT n) | n == ''(,,,,,,,,,) = TupleT 10+ go (ConT n) | n == ''(,,,,,,,,,,) = TupleT 11+ go (ConT n) | n == ''(,,,,,,,,,,,) = TupleT 12+ go (ConT n) | n == ''(,,,,,,,,,,,,) = TupleT 13+ go (ConT n) | n == ''(,,,,,,,,,,,,,) = TupleT 14+ go (ConT n) | n == ''(,,,,,,,,,,,,,,) = TupleT 15+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,) = TupleT 16+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,) = TupleT 17+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,) = TupleT 18+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,) = TupleT 19+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,) = TupleT 20+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,) = TupleT 21+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,) = TupleT 22+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,) = TupleT 23+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 24+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 25+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 26+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 27+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 28+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 29+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 30+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 31+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 32+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 33+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 34+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 35+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 36+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 37+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 38+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 39+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 40+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 41+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 42+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 43+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 44+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 45+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 46+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 47+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 48+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 49+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 50+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 51+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 52+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 53+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 54+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 55+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 56+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 57+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 58+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 59+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 60+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 61+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 62+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 63+ go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 64+ go t = t++++-----------------------------------------------------------------------------+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Language/Haskell/TH/Instances/Lift.hs view
@@ -1,89 +1,89 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving, TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} - -{- | - Module : Language.Haskell.TH.Instances.Lift - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow <mjm2002@gmail.com> - Stability : experimental - Portability : portable (template-haskell) --} - -module Language.Haskell.TH.Instances.Lift () where - -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Lift (deriveLiftMany) - -deriving instance Ord Exp -deriving instance Ord Dec -deriving instance Ord Stmt -deriving instance Ord Type -deriving instance Ord Foreign -deriving instance Ord FunDep -deriving instance Ord Con -deriving instance Ord Body -deriving instance Ord Clause -deriving instance Ord Strict -deriving instance Ord Safety -deriving instance Ord Callconv -deriving instance Ord Guard -deriving instance Ord Range -deriving instance Ord Match -deriving instance Ord Pat -deriving instance Ord Lit - -#if MIN_VERSION_template_haskell(2,4,0) -deriving instance Ord TyVarBndr -deriving instance Ord Pred -deriving instance Ord Kind -deriving instance Ord FamFlavour -deriving instance Ord InlineSpec -deriving instance Ord Pragma -#endif /* MIN_VERSION_template_haskell(2,4,0) */ - -deriving instance Show Loc -deriving instance Eq Loc - --- TODO: make this better -instance Ppr Loc where - ppr = showtextl . show - -instance Ppr Lit where - ppr l = ppr (LitE l) - -$(deriveLiftMany [ ''Body - , ''Callconv - , ''Clause - , ''Con - , ''Dec - , ''Exp - , ''Fixity - , ''FixityDirection - , ''Foreign - , ''FunDep - , ''Guard - , ''Info - , ''Lit - , ''Match - , ''Pat - , ''Range - , ''Safety - , ''Stmt - , ''Strict - , ''Type -#if MIN_VERSION_template_haskell(2,4,0) - , ''FamFlavour - , ''InlineSpec - , ''Kind - , ''Pragma - , ''Pred - , ''TyVarBndr -#if MIN_VERSION_template_haskell(2,5,0) - , ''ClassInstance -#endif /* MIN_VERSION_template_haskell(2,5,0) */ -#endif /* MIN_VERSION_template_haskell(2,4,0) */ - ]) - +{-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving, TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++{- |+ Module : Language.Haskell.TH.Instances.Lift+ Copyright : (c) Matt Morrow 2008+ License : BSD3+ Maintainer : Matt Morrow <mjm2002@gmail.com>+ Stability : experimental+ Portability : portable (template-haskell)+-}++module Language.Haskell.TH.Instances.Lift () where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Lift (deriveLiftMany)++deriving instance Ord Exp+deriving instance Ord Dec+deriving instance Ord Stmt+deriving instance Ord Type+deriving instance Ord Foreign+deriving instance Ord FunDep+deriving instance Ord Con+deriving instance Ord Body+deriving instance Ord Clause+deriving instance Ord Strict+deriving instance Ord Safety+deriving instance Ord Callconv+deriving instance Ord Guard+deriving instance Ord Range+deriving instance Ord Match+deriving instance Ord Pat+deriving instance Ord Lit++#if MIN_VERSION_template_haskell(2,4,0)+deriving instance Ord TyVarBndr+deriving instance Ord Pred+deriving instance Ord Kind+deriving instance Ord FamFlavour+deriving instance Ord InlineSpec+deriving instance Ord Pragma+#endif /* MIN_VERSION_template_haskell(2,4,0) */++deriving instance Show Loc+deriving instance Eq Loc++-- TODO: make this better+instance Ppr Loc where+ ppr = showtextl . show++instance Ppr Lit where+ ppr l = ppr (LitE l)++$(deriveLiftMany [ ''Body+ , ''Callconv+ , ''Clause+ , ''Con+ , ''Dec+ , ''Exp+ , ''Fixity+ , ''FixityDirection+ , ''Foreign+ , ''FunDep+ , ''Guard+ , ''Info+ , ''Lit+ , ''Match+ , ''Pat+ , ''Range+ , ''Safety+ , ''Stmt+ , ''Strict+ , ''Type+#if MIN_VERSION_template_haskell(2,4,0)+ , ''FamFlavour+ , ''InlineSpec+ , ''Kind+ , ''Pragma+ , ''Pred+ , ''TyVarBndr+#if MIN_VERSION_template_haskell(2,5,0)+ , ''ClassInstance+#endif /* MIN_VERSION_template_haskell(2,5,0) */+#endif /* MIN_VERSION_template_haskell(2,4,0) */+ ])+