diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. + +----------------------------------------------------------------------------- + diff --git a/README b/README --- a/README +++ b/README @@ -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) diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ -> import Distribution.Simple -> main :: IO () +> import Distribution.Simple +> main :: IO () > main = defaultMain diff --git a/examples/BF.hs b/examples/BF.hs --- a/examples/BF.hs +++ b/examples/BF.hs @@ -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)], []) +-} + + + + + + diff --git a/examples/Hs.hs b/examples/Hs.hs --- a/examples/Hs.hs +++ b/examples/Hs.hs @@ -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) + } diff --git a/examples/HsHere.hs b/examples/HsHere.hs --- a/examples/HsHere.hs +++ b/examples/HsHere.hs @@ -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 ']' + diff --git a/examples/SKI.hs b/examples/SKI.hs --- a/examples/SKI.hs +++ b/examples/SKI.hs @@ -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 +-} + + + diff --git a/haskell-src-meta.cabal b/haskell-src-meta.cabal --- a/haskell-src-meta.cabal +++ b/haskell-src-meta.cabal @@ -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 -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 +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 + diff --git a/src/Language/Haskell/Meta.hs b/src/Language/Haskell/Meta.hs --- a/src/Language/Haskell/Meta.hs +++ b/src/Language/Haskell/Meta.hs @@ -1,18 +1,18 @@ - -{- | - Module : Language.Haskell.Meta - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow - Stability : experimental - Portability : portable (template-haskell) --} - -module Language.Haskell.Meta ( - module Language.Haskell.Meta.Parse, - module Language.Haskell.Meta.Syntax.Translate -) where - -import Language.Haskell.Meta.Parse -import Language.Haskell.Meta.Syntax.Translate -import Language.Haskell.TH.Instances.Lift() + +{- | + Module : Language.Haskell.Meta + Copyright : (c) Matt Morrow 2008 + License : BSD3 + Maintainer : Matt Morrow + Stability : experimental + Portability : portable (template-haskell) +-} + +module Language.Haskell.Meta ( + module Language.Haskell.Meta.Parse, + module Language.Haskell.Meta.Syntax.Translate +) where + +import Language.Haskell.Meta.Parse +import Language.Haskell.Meta.Syntax.Translate +import Language.Haskell.TH.Instances.Lift() diff --git a/src/Language/Haskell/Meta/Parse.hs b/src/Language/Haskell/Meta/Parse.hs --- a/src/Language/Haskell/Meta/Parse.hs +++ b/src/Language/Haskell/Meta/Parse.hs @@ -1,163 +1,163 @@ -{- | - Module : Language.Haskell.Meta.Parse - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow - Stability : experimental - Portability : portable (template-haskell) --} - -module Language.Haskell.Meta.Parse ( - parsePat, - parseExp, - parseType, - parseDecs, - myDefaultParseMode, - myDefaultExtensions, - parseResultToEither, - parseHsModule, - parseHsDecls, - parseHsType, - parseHsExp, - parseHsPat, - pprHsModule, - moduleDecls, - emptySrcLoc, - emptyHsModule - ) where - -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 + 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 +-} + +----------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Meta/Syntax/Translate.hs b/src/Language/Haskell/Meta/Syntax/Translate.hs --- a/src/Language/Haskell/Meta/Syntax/Translate.hs +++ b/src/Language/Haskell/Meta/Syntax/Translate.hs @@ -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 - 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 + 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 + + +----------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Meta/Utils.hs b/src/Language/Haskell/Meta/Utils.hs --- a/src/Language/Haskell/Meta/Utils.hs +++ b/src/Language/Haskell/Meta/Utils.hs @@ -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 + + + +----------------------------------------------------------------------------- + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/Language/Haskell/TH/Instances/Lift.hs b/src/Language/Haskell/TH/Instances/Lift.hs --- a/src/Language/Haskell/TH/Instances/Lift.hs +++ b/src/Language/Haskell/TH/Instances/Lift.hs @@ -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 - 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 + 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) */ + ]) +