haskell-src-meta 0.4.0.2 → 0.5
raw patch · 13 files changed
+2201/−2187 lines, 13 filesdep ~basedep ~template-haskellsetup-changednew-uploaderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, template-haskell
API changes (from Hackage documentation)
+ Language.Haskell.Meta.Syntax.Translate: instance ToDecs InstDecl
Files
- LICENSE +168/−168
- README +54/−51
- 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/−45
- src/Language/Haskell/Meta.hs +18/−18
- src/Language/Haskell/Meta/Parse.hs +163/−163
- src/Language/Haskell/Meta/Syntax/Translate.hs +652/−642
- 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,51 +1,54 @@-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.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.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,45 +1,46 @@-name: haskell-src-meta-version: 0.4.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-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.1 && < 4.5,- haskell-src-exts >= 1.6 && < 1.12,- template-haskell >= 2.3 && < 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 +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,642 +1,652 @@-{-# 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 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 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 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 + + +-----------------------------------------------------------------------------
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) */ + ]) +