haskell-src-meta-0.8.12/0000755000000000000000000000000007346545000013127 5ustar0000000000000000haskell-src-meta-0.8.12/ChangeLog0000644000000000000000000001147307346545000014707 0ustar00000000000000000.8.12 - Support for GHC 9.6 (by Troels Henriksen) 0.8.11 - Support for GHC 9.4 (by Matt Parsons) 0.8.10 - Support for GHC 9.4 alpha (by Matt Parsons) 0.8.9 - Add `toExtension` and `fromExtension` to convert between HSE and TH language extensions (by Konstantin Ivanov) 0.8.8 - Implement toDec for AnnPragma (by Matt Torrence) - Add support for OverloadedLabels (by funketh) - Fix order of promoted type tuples in resulting TH (by Alexander V. Nikolaev) 0.8.7.1 - Build on GHC 9.2 - Drop support for GHC < 8.2 0.8.7: - Compatibility with template-haskell shipped with GHC 9.0 0.8.6: - Add TypeApplications to default extensions 0.8.5: - Compatibility with template-haskell shipped with GHC 8.10 0.8.4: - Bump base and template-haskell library to versions shipped with GHC 7.10 - Compatibility with haskell-src-exts 1.22 0.8.3: - Compatibility with GHC 8.8, by fixing MonadFail issues 0.8.2: - Added ToExp implementation for type application - Added parseDecsWithMode and parseHsDeclsWithMode 0.8.1: - Compatibility with GHC 8.6, haskell-src-exts 1.21 0.8.0.1: - Bump base and template-haskell library to versions shipped with GHC 7.6. 0.8: - Compatibility with GHC 8.2. - Remove deprecated modules. 0.7.0.1: - Fixed a bug that caused deriving clauses to be ignored on TH 2.11. 0.7.0: - Compatibility with haskell-src-exts 1.18. - Support dropped for GHC < 7.6 and haskell-src-exts < 1.17. 0.6.0.14: - Compatibility with GHC 8.0. 0.6.0.13: - Compatibility with GHC HEAD, haskell-src-exts 1.17 - Remove hsBindsToDecs, since it was redundant with toDecs. Technically this requires a minor-version bump, but I doubt anyone was using it. 0.6.0.12: - Support th-orphans 0.13 0.6.0.11: - Support syb 0.6 0.6.0.10: - Support syb 0.5, th-orphans 0.12 0.6.0.9: - Compatibility with GHC 7.10 - Update th-orphans dependency - Drop GHC < 7.4 support (actually it was already broken, since HSE 1.16 requires base >= 4.5) 0.6.0.8: - Move to HSE 1.16 0.6.0.7: - Fix compilation oops 0.6.0.6: - Move to HSE 1.15, adding support for multiway if 0.6.0.5: - Update th-orphans dependency 0.6.0.4: - Drop support for GHC 6.12 - Move to HSE 1.14 0.6.0.3: - Update th-orphans dependency - Some dependency loosening in anticipation of GHC 7.8 0.6.0.2: - Update syb dependency 0.6.0.1: - Fix haddock parse error 0.6: - Cabal category Template Haskell - Partial support for list comprehensions - Support for type and data families and class decs - Split orphan instances into new package th-orphans - above changes courtesy of mgsloan - L.H.TH.Instances.Lift now deprecated - Removed L.H.M.Utils.deriveLiftPretty, dropped th-lift dependency - Rename L.H.M.Utils.unQ to unsafeRunQ - instance ToName Op - Support for unboxed tuple types and kind signatures - Compatibility with GHC 7.6.1, bringing support for kind variables and infix declarations 0.5.1.2: - More sensible determination of TH version available 0.5.1.1: - View pattern support, thanks to Nicolas Frisby. 0.5.1: - New module Language.Haskell.Meta.Parse.Careful, written by Reiner Pope so that ambiguous parses can be rejected instead of quietly done wrong. 0.5.0.3: - Support for GHC 7.4, thanks to Reiner Pope - Support for unresolved infix expressions, again thanks to Reiner Pope 0.5.0.2: - Fixed bug in translation of tuple constructors 0.5.0.1: - Added support for primitive string literals (Only in TH >= 2.5) 0.5: - Added support for instance declarations 0.4.0.2: - Compatibility with GHC 7.2 0.4.0.1: - Deprecate myDefaultParseMode and myDefaultExtensions in L.H.M.Parse 0.4: - Remove Language.Haskell.Meta.Syntax.Vars and the L.H.M.Syntax re-export module - Remove dependency on containers - Add support for let statements in (pattern) guards - Add support for negative patterns - Remove "support" for SpliceExps that didn't really make sense - Improve many error messages where things are unimplemented or impossible 0.3: - Fixes/additions to inline pragma support (Jonas Duregard) - Compatibility with GHC 7 and TH 2.5 - totalling three major versions! - Move some of the quasiquoters to their own package, and stop exporting the rest (they are kept as examples of usage) 0.2: - Compatibility with GHC 6.10 and TH 2.3 (Geoffrey Mainland) - Add support for do-blocks, pattern guards (Adam Vogt) - Add applicative-do quasiquoter (Adam Vogt) 0.1.1: - Add support for inline pragmas, and improve support for type signatures (patch by Jonas Duregard) 0.1.0: - Used the th-lift library to autogenerate the instances of Lift in Language.Haskell.TH.Instances.Lift - Added support for the new features of template-haskell-2.4.0.0: contexts, kinds, bang patterns, unboxed word literals. - Updated use of haskell-src-exts in response to API changes. - Added ToDecs class because some HSE Decls don't map to a single Dec. (patch by Jonas Duregard) 0.0.6: - last version released by Matt Morrow before his disappearance haskell-src-meta-0.8.12/LICENSE0000644000000000000000000001744007346545000014142 0ustar0000000000000000----------------------------------------------------------------------------- ----------------------------------------------------------------------------- metaquote Copyright (c) Matt Morrow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The names of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- th-lift Copyright (c) Ian Lynagh. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The names of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- haskell-src-exts This library (Haskell Source eXtensions) is derived from code from several sources: * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). The full text of these licenses is reproduced below. All of the licenses are BSD-style or compatible. ----------------------------------------------------------------------------- The haskell-src-exts package itself is distributable under the modified BSD license: Copyright (c) 2005, Niklas Broberg All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The names of its contributors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------- The Glasgow Haskell Compiler License Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ----------------------------------------------------------------------------- Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: Copyright (c) 2002 Simon Peyton Jones The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, including this Notice. Modified versions of this Report may also be copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. ----------------------------------------------------------------------------- haskell-src-meta-0.8.12/README.md0000644000000000000000000000173107346545000014410 0ustar0000000000000000The `haskell-src-meta` Package [![Hackage](https://img.shields.io/hackage/v/haskell-src-meta.svg)](https://hackage.haskell.org/package/haskell-src-meta) [![Build Status](https://travis-ci.org/DanBurton/haskell-src-meta.svg)](https://travis-ci.org/DanBurton/haskell-src-meta) ================== `haskell-src-meta` is a package originally by Matt Morrow for converting a parsed AST from `haskell-src-exts` to a TH AST for use in splices and quasiquoters. The last version Matt released before he disappeared from the Haskell community was 0.0.6, but by that time his library was already popular, so some community members eventually decided to take over maintenance of the package, keeping it up to date with the latest versions of TH etc. I don't really view this as "my" package so if you want write access to the github repository, or you think you could do a better job as maintainer, just ask. The above was written by Ben Millwood, but I (Dan Burton) share the same sentiment. haskell-src-meta-0.8.12/Setup.lhs0000644000000000000000000000010107346545000014727 0ustar0000000000000000> import Distribution.Simple > main :: IO () > main = defaultMainhaskell-src-meta-0.8.12/examples/0000755000000000000000000000000007346545000014745 5ustar0000000000000000haskell-src-meta-0.8.12/examples/BF.hs0000644000000000000000000001474607346545000015604 0ustar0000000000000000-- TODO: knock out these warnings {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module BF ( bf,bf2,bfHelloWorld,eval_,parse, exec, test0 ) where import Language.Haskell.Meta (parsePat) import Language.Haskell.TH.Lib import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import qualified Control.Monad.Fail as Fail import Data.Char import Data.IntMap (IntMap) import qualified Data.IntMap as IM -- TODO: narrow type & move to shared module quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++) -- TODO: narrow type & move to shared module quoteDecNotImplemented :: Fail.MonadFail m => String -> m a quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ ) bf :: QuasiQuoter bf = QuasiQuoter { quoteExp = bfExpQ , quotePat = bfPatQ , quoteType = quoteTypeNotImplemented , quoteDec = quoteDecNotImplemented } bf2 :: QuasiQuoter bf2 = QuasiQuoter { quoteExp = bf2ExpQ , quotePat = bfPatQ , quoteType = quoteTypeNotImplemented , quoteDec = quoteDecNotImplemented } 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)|] #if MIN_VERSION_template_haskell(2,17,0) liftTyped = unsafeCodeCoerce . lift #elif MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift -- TODO: get stylish haskell to be happy w/ the below -- liftTyped Inp = [||Inp||] -- liftTyped Out = [||Out||] -- liftTyped Inc = [||Inc||] -- liftTyped Dec = [||Dec||] -- liftTyped MovL = [||MovL||] -- liftTyped MovR = [||MovR||] -- liftTyped (While xs) = [||While $$(liftTyped xs)||] #endif 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 :: IO [Bf] test0 = do a <- readFile "prime.bf" return (parse a) {- data Bf = Inp | Out | Inc | Dec | MovL | MovR | While [Bf] | Error String deriving (Eq,Ord,Read,Show) parse :: String -> [Bf] parse s = let p n s = case go n [] s of (_,xs,[]) -> xs (n,xs, s) -> xs ++ p n s in p 0 s where go :: Int -> [Bf] -> [Char] -> (Int, [Bf], String) go !n acc [] = (n, reverse acc, []) go !n acc (',':cs) = go (n+1) (Inp:acc) cs go !n acc ('.':cs) = go (n+1) (Out:acc) cs go !n acc ('+':cs) = go (n+1) (Inc:acc) cs go !n acc ('-':cs) = go (n+1) (Dec:acc) cs go !n acc ('<':cs) = go (n+1) (MovL:acc) cs go !n acc ('>':cs) = go (n+1) (MovR:acc) cs go !n acc ('[':cs) = case go (n+1) [] cs of (n,xs,cs) -> go n (While xs:acc) cs go !n acc (']':cs) = (n+1, reverse acc, cs) go !n acc (c :cs) = (n+1, [Error ("go error: char "++show n ++" illegal character: "++show c)], []) -} haskell-src-meta-0.8.12/examples/Hs.hs0000644000000000000000000000260307346545000015654 0ustar0000000000000000 -- | Eat your face! module 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 import qualified Control.Monad.Fail as Fail -- TODO: narrow type & move to shared module quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++) -- TODO: narrow type & move to shared module quoteDecNotImplemented :: Fail.MonadFail m => String -> m a quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ ) -- | -- > 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 , quoteType = quoteTypeNotImplemented , quoteDec = quoteDecNotImplemented } 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) , quoteType = quoteTypeNotImplemented , quoteDec = quoteDecNotImplemented } haskell-src-meta-0.8.12/examples/HsHere.hs0000644000000000000000000001046707346545000016467 0ustar0000000000000000-- TODO: knock out these warnings {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} module HsHere ( here , lexemeP , nestedP , parensP , bracksP , oparenP , obrackP , cbrackP ) where import qualified Control.Monad.Fail as Fail import Data.Generics (Data) import Data.Typeable (Typeable) import Language.Haskell.Meta (parseExp, parsePat) import Language.Haskell.Meta.Utils (cleanNames) import Language.Haskell.TH.Lib hiding (parensP) import Language.Haskell.TH.Ppr import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Text.ParserCombinators.ReadP -- TODO: narrow type & move to shared module quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++) -- TODO: narrow type & move to shared module quoteDecNotImplemented :: Fail.MonadFail m => String -> m a quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ ) 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 {quoteType = quoteTypeNotImplemented ,quoteDec = quoteDecNotImplemented ,quoteExp = hereExpQ ,quotePat = herePatQ} instance Lift Here where lift (TextH s) = (litE . stringL) s lift (CodeH e) = [|show $(return e)|] lift (ManyH hs) = [|concat $(listE (fmap lift hs))|] #if MIN_VERSION_template_haskell(2,17,0) liftTyped = unsafeCodeCoerce . lift #elif MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift -- TODO: the right way? #endif 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 :: Int -> String -> String -> ReadP Here 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, bracksP :: ReadP a -> ReadP a parensP = between oparenP cparenP bracksP = between oparenP cparenP oparenP, cparenP, obrackP, cbrackP :: ReadP Char oparenP = char '(' cparenP = char ')' obrackP = char '[' cbrackP = char ']' haskell-src-meta-0.8.12/examples/SKI.hs0000644000000000000000000001271007346545000015730 0ustar0000000000000000-- TODO: knock out these warnings {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} module SKI ( SKI(..) , ski , parse , bracksP , obrackP , cbrackP ) where import qualified Control.Monad.Fail as Fail import Data.Generics (Data) import Data.Typeable (Typeable) import Language.Haskell.Meta (parseExp, parsePat) import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unsafeRunQ) import Language.Haskell.TH.Lib hiding (parensP) import Language.Haskell.TH.Ppr import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Text.ParserCombinators.ReadP import Text.PrettyPrint (render) -- TODO: narrow type & move to shared module quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++) -- TODO: narrow type & move to shared module quoteDecNotImplemented :: Fail.MonadFail m => String -> m a quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ ) 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 (unsafeRunQ[|$(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 (unsafeRunQ[|$(return e) $(return e')|]) eval0 x = x ski :: QuasiQuoter ski = QuasiQuoter { quoteExp = skiExpQ , quotePat = skiPatQ , quoteType = quoteTypeNotImplemented , quoteDec = quoteDecNotImplemented } instance Lift SKI where lift = liftSKI #if MIN_VERSION_template_haskell(2,17,0) liftTyped = unsafeCodeCoerce . lift #elif MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift -- TODO: the right way? #endif liftSKI (E e) = return e liftSKI a = go a where go S = [|S|] go K = [|K|] go I = [|I|] go (E e) = [|E e|] go (x:$y) = [|$(go x) :$ $(go y)|] instance Show SKI where showsPrec p (S) = showString "S" showsPrec p (K) = showString "K" showsPrec p (I) = showString "I" showsPrec p (E x1) = showParen (p > 10) (showString (render (ppDoc x1))) showsPrec p ((:$) x1 x2) = showParen (p > 10) (showsPrec 11 x1 . (showString " :$ " . showsPrec 10 x2)) skiExpQ :: String -> ExpQ skiExpQ s = case run s of [] -> fail "ski: parse error" e:_ -> lift (cleanNames e) skiPatQ :: String -> PatQ skiPatQ s = do e <- skiExpQ s let p = (parsePat . pprint . cleanNames) e case p of Left e -> fail e Right p -> return p -- ghci> parse "S(SS)IK(SK)" -- ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"") parse :: String -> ([SKI], String) parse = runP skiP skiP :: ReadP SKI skiP = nestedP parensP (let go a = (do b <- lexemeP (oneP <++ skiP) go (a:$b)) <++ return a in lexemeP (go =<< lexemeP oneP)) oneP :: ReadP SKI oneP = nestedP parensP (lexemeP (choice [sP ,kP ,iP ,spliceP =<< look ])) spliceP :: String -> ReadP SKI spliceP s | '[':s <- s = skip 1 >> go 1 [] s | otherwise = pfail where go _ _ [] = pfail go 1 acc (']':_) = do skip (1 + length acc) either (const pfail) (return . E) (parseExp (reverse acc)) go n acc ('[':s) = go (n+1) ('[':acc) s go n acc (']':s) = go (n-1) (']':acc) s go n acc (c:s) = go n (c:acc) s sP = (char 's' +++ char 'S') >> return S kP = (char 'k' +++ char 'K') >> return K iP = (char 'i' +++ char 'I') >> return I runP :: ReadP a -> String -> ([a], String) runP p s = case readP_to_S p s of [] -> ([],[]) xs -> mapfst (:[]) (last xs) where mapfst f (a,b) = (f a,b) skip :: Int -> ReadP () skip n = count n get >> return () lexemeP :: ReadP a -> ReadP a lexemeP p = p >>= \x -> skipSpaces >> return x nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a) nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p) parensP = between oparenP cparenP bracksP = between oparenP cparenP oparenP = char '(' cparenP = char ')' obrackP = char '[' cbrackP = char ']' {- import Prelude hiding (($)) data Komb = S (Maybe (Komb, Maybe Komb)) | K (Maybe Komb) deriving Show S Nothing $ x = S (Just (x, Nothing)) S (Just (x, Nothing)) $ y = S (Just (x, Just y)) S (Just (x, Just y)) $ z = x $ z $ (y $ z) K Nothing $ x = K (Just x) K (Just x) $ y = y q x = x $ (c $ k) $ k $ k $ s where s = S Nothing k = K Nothing c = s $ (b $ b $ s) $ k $ k b = s $ (k $ s) $ k -} haskell-src-meta-0.8.12/haskell-src-meta.cabal0000644000000000000000000000472107346545000017253 0ustar0000000000000000name: haskell-src-meta version: 0.8.12 cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: LICENSE category: Language, Template Haskell author: Matt Morrow copyright: (c) Matt Morrow maintainer: danburton.email@gmail.com bug-reports: https://github.com/haskell-party/haskell-src-meta/issues tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.2, GHC == 9.4.1, GHC == 9.6.1 synopsis: Parse source to template-haskell abstract syntax. description: The translation from haskell-src-exts abstract syntax to template-haskell abstract syntax isn't 100% complete yet. extra-source-files: ChangeLog README.md library default-language: Haskell2010 build-depends: base >= 4.10 && < 5, haskell-src-exts >= 1.21 && < 1.24, pretty >= 1.0 && < 1.2, syb >= 0.1 && < 0.8, template-haskell >= 2.12 && < 2.21, th-orphans >= 0.12 && < 0.14 hs-source-dirs: src exposed-modules: Language.Haskell.Meta Language.Haskell.Meta.Extensions Language.Haskell.Meta.Parse Language.Haskell.Meta.Syntax.Translate Language.Haskell.Meta.Utils other-modules: Language.Haskell.Meta.THCompat test-suite unit default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Main.hs build-depends: HUnit >= 1.2, base >= 4.10, haskell-src-exts >= 1.21, haskell-src-meta, pretty >= 1.0, template-haskell >= 2.12, tasty, tasty-hunit test-suite splices default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Splices.hs build-depends: base, haskell-src-exts, haskell-src-meta, template-haskell test-suite examples default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: examples, tests main-is: TestExamples.hs build-depends: base, containers, haskell-src-meta, pretty, syb, template-haskell other-modules: BF, Hs, HsHere, SKI source-repository head type: git location: git://github.com/haskell-party/haskell-src-meta.git haskell-src-meta-0.8.12/src/Language/Haskell/0000755000000000000000000000000007346545000017024 5ustar0000000000000000haskell-src-meta-0.8.12/src/Language/Haskell/Meta.hs0000644000000000000000000000107007346545000020244 0ustar0000000000000000{- | Module : Language.Haskell.Meta Copyright : (c) Matt Morrow 2008 License : BSD3 Maintainer : Matt Morrow Stability : experimental Portability : portable (template-haskell) -} module Language.Haskell.Meta ( module Language.Haskell.Meta.Extensions, module Language.Haskell.Meta.Parse, module Language.Haskell.Meta.Syntax.Translate ) where import Language.Haskell.Meta.Extensions import Language.Haskell.Meta.Parse import Language.Haskell.Meta.Syntax.Translate import Language.Haskell.TH.Instances () haskell-src-meta-0.8.12/src/Language/Haskell/Meta/0000755000000000000000000000000007346545000017712 5ustar0000000000000000haskell-src-meta-0.8.12/src/Language/Haskell/Meta/Extensions.hs0000644000000000000000000004126207346545000022412 0ustar0000000000000000{-# LANGUAGE CPP #-} {- | Module : Language.Haskell.Meta.Parse Copyright : (c) Serokell 2022, Adam Bergmark 2022 License : BSD3 Maintainer : Adam Bergmark Stability : experimental Portability : portable (template-haskell) -} module Language.Haskell.Meta.Extensions ( toExtension, fromExtension ) where import qualified Language.Haskell.Exts.Extension as Exts import qualified Language.Haskell.TH.Syntax as TH ----------------------------------------------------------------------------- -- * To template-haskell -- | Returns @Nothing@ when the extension is not supported by template-haskell. toExtension :: Exts.KnownExtension -> Maybe TH.Extension toExtension e = case e of Exts.OverlappingInstances -> Just TH.OverlappingInstances Exts.UndecidableInstances -> Just TH.UndecidableInstances Exts.IncoherentInstances -> Just TH.IncoherentInstances Exts.InstanceSigs -> Just TH.InstanceSigs Exts.DoRec -> Nothing Exts.RecursiveDo -> Just TH.RecursiveDo Exts.ParallelListComp -> Just TH.ParallelListComp Exts.MultiParamTypeClasses -> Just TH.MultiParamTypeClasses Exts.MonomorphismRestriction -> Just TH.MonomorphismRestriction Exts.FunctionalDependencies -> Just TH.FunctionalDependencies Exts.Rank2Types -> Nothing Exts.RankNTypes -> Just TH.RankNTypes Exts.PolymorphicComponents -> Nothing Exts.ExistentialQuantification -> Just TH.ExistentialQuantification Exts.ScopedTypeVariables -> Just TH.ScopedTypeVariables Exts.PatternSignatures -> Nothing Exts.ImplicitParams -> Just TH.ImplicitParams Exts.FlexibleContexts -> Just TH.FlexibleContexts Exts.FlexibleInstances -> Just TH.FlexibleInstances Exts.EmptyDataDecls -> Just TH.EmptyDataDecls Exts.CPP -> Just TH.Cpp Exts.KindSignatures -> Just TH.KindSignatures Exts.BangPatterns -> Just TH.BangPatterns Exts.TypeSynonymInstances -> Just TH.TypeSynonymInstances Exts.TemplateHaskell -> Just TH.TemplateHaskell Exts.ForeignFunctionInterface -> Just TH.ForeignFunctionInterface Exts.Arrows -> Just TH.Arrows Exts.Generics -> Nothing Exts.ImplicitPrelude -> Just TH.ImplicitPrelude Exts.NamedFieldPuns -> Nothing Exts.PatternGuards -> Just TH.PatternGuards Exts.GeneralizedNewtypeDeriving -> Just TH.GeneralizedNewtypeDeriving Exts.DeriveAnyClass -> Just TH.DeriveAnyClass Exts.ExtensibleRecords -> Nothing Exts.RestrictedTypeSynonyms -> Nothing Exts.HereDocuments -> Nothing Exts.MagicHash -> Just TH.MagicHash Exts.BinaryLiterals -> Just TH.BinaryLiterals Exts.TypeFamilies -> Just TH.TypeFamilies Exts.StandaloneDeriving -> Just TH.StandaloneDeriving Exts.UnicodeSyntax -> Just TH.UnicodeSyntax Exts.UnliftedFFITypes -> Just TH.UnliftedFFITypes Exts.LiberalTypeSynonyms -> Just TH.LiberalTypeSynonyms Exts.TypeOperators -> Just TH.TypeOperators Exts.ParallelArrays -> Just TH.ParallelArrays Exts.RecordWildCards -> Just TH.RecordWildCards #if __GLASGOW_HASKELL__ >= 904 Exts.RecordPuns -> Just TH.NamedFieldPuns #else Exts.RecordPuns -> Just TH.RecordPuns #endif Exts.DisambiguateRecordFields -> Just TH.DisambiguateRecordFields Exts.OverloadedStrings -> Just TH.OverloadedStrings Exts.GADTs -> Just TH.GADTs Exts.MonoPatBinds -> #if !MIN_VERSION_template_haskell(2,18,0) Just TH.MonoPatBinds #else Nothing #endif Exts.RelaxedPolyRec -> Just TH.RelaxedPolyRec Exts.ExtendedDefaultRules -> Just TH.ExtendedDefaultRules Exts.UnboxedTuples -> Just TH.UnboxedTuples Exts.DeriveDataTypeable -> Just TH.DeriveDataTypeable Exts.ConstrainedClassMethods -> Just TH.ConstrainedClassMethods Exts.PackageImports -> Just TH.PackageImports Exts.LambdaCase -> Just TH.LambdaCase Exts.EmptyCase -> Just TH.EmptyCase Exts.ImpredicativeTypes -> Just TH.ImpredicativeTypes Exts.NewQualifiedOperators -> Nothing Exts.PostfixOperators -> Just TH.PostfixOperators Exts.QuasiQuotes -> Just TH.QuasiQuotes Exts.TransformListComp -> Just TH.TransformListComp Exts.ViewPatterns -> Just TH.ViewPatterns Exts.XmlSyntax -> Nothing Exts.RegularPatterns -> Nothing Exts.TupleSections -> Just TH.TupleSections Exts.GHCForeignImportPrim -> Just TH.GHCForeignImportPrim Exts.NPlusKPatterns -> Just TH.NPlusKPatterns Exts.DoAndIfThenElse -> Just TH.DoAndIfThenElse Exts.RebindableSyntax -> Just TH.RebindableSyntax Exts.ExplicitForAll -> Just TH.ExplicitForAll Exts.DatatypeContexts -> Just TH.DatatypeContexts Exts.MonoLocalBinds -> Just TH.MonoLocalBinds Exts.DeriveFunctor -> Just TH.DeriveFunctor Exts.DeriveGeneric -> Just TH.DeriveGeneric Exts.DeriveTraversable -> Just TH.DeriveTraversable Exts.DeriveFoldable -> Just TH.DeriveFoldable Exts.NondecreasingIndentation -> Just TH.NondecreasingIndentation Exts.InterruptibleFFI -> Just TH.InterruptibleFFI Exts.CApiFFI -> Just TH.CApiFFI Exts.JavaScriptFFI -> Just TH.JavaScriptFFI Exts.ExplicitNamespaces -> Just TH.ExplicitNamespaces Exts.DataKinds -> Just TH.DataKinds Exts.PolyKinds -> Just TH.PolyKinds Exts.MultiWayIf -> Just TH.MultiWayIf Exts.SafeImports -> Nothing Exts.Safe -> Nothing Exts.Trustworthy -> Nothing Exts.DefaultSignatures -> Just TH.DefaultSignatures Exts.ConstraintKinds -> Just TH.ConstraintKinds Exts.RoleAnnotations -> Just TH.RoleAnnotations Exts.PatternSynonyms -> Just TH.PatternSynonyms Exts.PartialTypeSignatures -> Just TH.PartialTypeSignatures Exts.NamedWildCards -> Just TH.NamedWildCards Exts.TypeApplications -> Just TH.TypeApplications Exts.TypeFamilyDependencies -> Just TH.TypeFamilyDependencies Exts.OverloadedLabels -> Just TH.OverloadedLabels Exts.DerivingStrategies -> Just TH.DerivingStrategies Exts.UnboxedSums -> Just TH.UnboxedSums #if MIN_VERSION_haskell_src_exts(1,21,0) Exts.TypeInType -> Just TH.TypeInType #endif Exts.Strict -> Just TH.Strict Exts.StrictData -> Just TH.StrictData #if MIN_VERSION_haskell_src_exts(1,21,0) Exts.DerivingVia -> #if MIN_VERSION_template_haskell(2,14,0) Just TH.DerivingVia #else Nothing #endif #endif #if MIN_VERSION_haskell_src_exts(1,22,0) Exts.QuantifiedConstraints -> #if MIN_VERSION_template_haskell(2,14,0) Just TH.QuantifiedConstraints #else Nothing #endif #endif #if MIN_VERSION_haskell_src_exts(1,23,0) Exts.BlockArguments -> #if MIN_VERSION_template_haskell(2,14,0) Just TH.BlockArguments #else Nothing #endif #endif -- NB: when adding a case here, you may also need to update `fromExtension` ----------------------------------------------------------------------------- -- * From template-haskell -- | Returns @Nothing@ when the extension is not supported by haskell-src-exts. fromExtension :: TH.Extension -> Maybe Exts.KnownExtension fromExtension e = case e of TH.Cpp -> Just Exts.CPP TH.OverlappingInstances -> Just Exts.OverlappingInstances TH.UndecidableInstances -> Just Exts.UndecidableInstances TH.IncoherentInstances -> Just Exts.IncoherentInstances TH.UndecidableSuperClasses -> Nothing TH.MonomorphismRestriction -> Just Exts.MonomorphismRestriction #if !MIN_VERSION_template_haskell(2,18,0) TH.MonoPatBinds -> Just Exts.MonoPatBinds #endif TH.MonoLocalBinds -> Just Exts.MonoLocalBinds TH.RelaxedPolyRec -> Just Exts.RelaxedPolyRec TH.ExtendedDefaultRules -> Just Exts.ExtendedDefaultRules TH.ForeignFunctionInterface -> Just Exts.ForeignFunctionInterface TH.UnliftedFFITypes -> Just Exts.UnliftedFFITypes TH.InterruptibleFFI -> Just Exts.InterruptibleFFI TH.CApiFFI -> Just Exts.CApiFFI TH.GHCForeignImportPrim -> Just Exts.GHCForeignImportPrim TH.JavaScriptFFI -> Just Exts.JavaScriptFFI TH.ParallelArrays -> Just Exts.ParallelArrays TH.Arrows -> Just Exts.Arrows TH.TemplateHaskell -> Just Exts.TemplateHaskell TH.TemplateHaskellQuotes -> Nothing TH.QuasiQuotes -> Just Exts.QuasiQuotes TH.ImplicitParams -> Just Exts.ImplicitParams TH.ImplicitPrelude -> Just Exts.ImplicitPrelude TH.ScopedTypeVariables -> Just Exts.ScopedTypeVariables TH.AllowAmbiguousTypes -> Nothing TH.UnboxedTuples -> Just Exts.UnboxedTuples TH.UnboxedSums -> Just Exts.UnboxedSums TH.BangPatterns -> Just Exts.BangPatterns TH.TypeFamilies -> Just Exts.TypeFamilies TH.TypeFamilyDependencies -> Just Exts.TypeFamilyDependencies TH.TypeInType -> #if MIN_VERSION_haskell_src_exts(1,21,0) Just Exts.TypeInType #else Nothing #endif TH.OverloadedStrings -> Just Exts.OverloadedStrings TH.OverloadedLists -> Nothing TH.NumDecimals -> Nothing TH.DisambiguateRecordFields -> Just Exts.DisambiguateRecordFields TH.RecordWildCards -> Just Exts.RecordWildCards #if __GLASGOW_HASKELL__ >= 904 TH.NamedFieldPuns -> Just Exts.RecordPuns TH.QualifiedDo -> Nothing TH.UnliftedDatatypes -> Nothing TH.LinearTypes -> Nothing TH.LexicalNegation -> Nothing TH.FieldSelectors -> Nothing TH.OverloadedRecordDot -> Nothing TH.OverloadedRecordUpdate -> Nothing #else TH.RecordPuns -> Just Exts.RecordPuns #endif TH.ViewPatterns -> Just Exts.ViewPatterns TH.GADTs -> Just Exts.GADTs TH.GADTSyntax -> Nothing TH.NPlusKPatterns -> Just Exts.NPlusKPatterns TH.DoAndIfThenElse -> Just Exts.DoAndIfThenElse TH.RebindableSyntax -> Just Exts.RebindableSyntax TH.ConstraintKinds -> Just Exts.ConstraintKinds TH.PolyKinds -> Just Exts.PolyKinds TH.DataKinds -> Just Exts.DataKinds TH.InstanceSigs -> Just Exts.InstanceSigs TH.ApplicativeDo -> Nothing TH.StandaloneDeriving -> Just Exts.StandaloneDeriving TH.DeriveDataTypeable -> Just Exts.DeriveDataTypeable TH.AutoDeriveTypeable -> Nothing TH.DeriveFunctor -> Just Exts.DeriveFunctor TH.DeriveTraversable -> Just Exts.DeriveTraversable TH.DeriveFoldable -> Just Exts.DeriveFoldable TH.DeriveGeneric -> Just Exts.DeriveGeneric TH.DefaultSignatures -> Just Exts.DefaultSignatures TH.DeriveAnyClass -> Just Exts.DeriveAnyClass TH.DeriveLift -> Nothing TH.DerivingStrategies -> Just Exts.DerivingStrategies TH.TypeSynonymInstances -> Just Exts.TypeSynonymInstances TH.FlexibleContexts -> Just Exts.FlexibleContexts TH.FlexibleInstances -> Just Exts.FlexibleInstances TH.ConstrainedClassMethods -> Just Exts.ConstrainedClassMethods TH.MultiParamTypeClasses -> Just Exts.MultiParamTypeClasses TH.NullaryTypeClasses -> Nothing TH.FunctionalDependencies -> Just Exts.FunctionalDependencies TH.UnicodeSyntax -> Just Exts.UnicodeSyntax TH.ExistentialQuantification -> Just Exts.ExistentialQuantification TH.MagicHash -> Just Exts.MagicHash TH.EmptyDataDecls -> Just Exts.EmptyDataDecls TH.KindSignatures -> Just Exts.KindSignatures TH.RoleAnnotations -> Just Exts.RoleAnnotations TH.ParallelListComp -> Just Exts.ParallelListComp TH.TransformListComp -> Just Exts.TransformListComp TH.MonadComprehensions -> Nothing TH.GeneralizedNewtypeDeriving -> Just Exts.GeneralizedNewtypeDeriving TH.RecursiveDo -> Just Exts.RecursiveDo TH.PostfixOperators -> Just Exts.PostfixOperators TH.TupleSections -> Just Exts.TupleSections TH.PatternGuards -> Just Exts.PatternGuards TH.LiberalTypeSynonyms -> Just Exts.LiberalTypeSynonyms TH.RankNTypes -> Just Exts.RankNTypes TH.ImpredicativeTypes -> Just Exts.ImpredicativeTypes TH.TypeOperators -> Just Exts.TypeOperators TH.ExplicitNamespaces -> Just Exts.ExplicitNamespaces TH.PackageImports -> Just Exts.PackageImports TH.ExplicitForAll -> Just Exts.ExplicitForAll TH.AlternativeLayoutRule -> Nothing TH.AlternativeLayoutRuleTransitional -> Nothing TH.DatatypeContexts -> Just Exts.DatatypeContexts TH.NondecreasingIndentation -> Just Exts.NondecreasingIndentation TH.RelaxedLayout -> Nothing TH.TraditionalRecordSyntax -> Nothing TH.LambdaCase -> Just Exts.LambdaCase TH.MultiWayIf -> Just Exts.MultiWayIf TH.BinaryLiterals -> Just Exts.BinaryLiterals TH.NegativeLiterals -> Nothing TH.DuplicateRecordFields -> Nothing TH.OverloadedLabels -> Just Exts.OverloadedLabels TH.EmptyCase -> Just Exts.EmptyCase TH.PatternSynonyms -> Just Exts.PatternSynonyms TH.PartialTypeSignatures -> Just Exts.PartialTypeSignatures TH.NamedWildCards -> Just Exts.NamedWildCards TH.StaticPointers -> Nothing TH.TypeApplications -> Just Exts.TypeApplications TH.Strict -> Just Exts.Strict TH.StrictData -> Just Exts.StrictData #if !MIN_VERSION_template_haskell(2,18,0) TH.MonadFailDesugaring -> Nothing #endif -- 2.13.0 ---------------------------------------- #if MIN_VERSION_template_haskell(2,13,0) TH.HexFloatLiterals -> Nothing TH.EmptyDataDeriving -> Nothing #endif -- 2.14.0 ---------------------------------------- #if MIN_VERSION_template_haskell(2,14,0) TH.DerivingVia -> #if MIN_VERSION_haskell_src_exts(1,21,0) Just Exts.DerivingVia #else Nothing #endif TH.QuantifiedConstraints -> #if MIN_VERSION_haskell_src_exts(1,22,0) Just Exts.QuantifiedConstraints #else Nothing #endif TH.BlockArguments -> #if MIN_VERSION_haskell_src_exts(1,23,0) Just Exts.BlockArguments #else Nothing #endif TH.NumericUnderscores -> Nothing TH.StarIsType -> Nothing #endif -- 2.16.0 ---------------------------------------- #if MIN_VERSION_template_haskell(2,16,0) TH.UnliftedNewtypes -> Nothing TH.ImportQualifiedPost -> Nothing TH.CUSKs -> Nothing TH.StandaloneKindSignatures -> Nothing #endif -- 2.19.0 --------------------------------------- #if MIN_VERSION_template_haskell(2,19,0) TH.DeepSubsumption -> Nothing #endif -- 2.20.0 --------------------------------------- #if MIN_VERSION_template_haskell(2,20,0) TH.TypeData -> Nothing #endif -- NB: when adding a case here, you may also need to update `toExtension` ----------------------------------------------------------------------------- haskell-src-meta-0.8.12/src/Language/Haskell/Meta/Parse.hs0000644000000000000000000001150007346545000021315 0ustar0000000000000000{-# LANGUAGE CPP #-} {- | Module : Language.Haskell.Meta.Parse Copyright : (c) Matt Morrow 2008 License : BSD3 Maintainer : Matt Morrow Stability : experimental Portability : portable (template-haskell) -} module Language.Haskell.Meta.Parse ( parsePat, parseExp, parseType, parseDecs, parseDecsWithMode, myDefaultParseMode, myDefaultExtensions, parseResultToEither, parseHsModule, parseHsDecls, parseHsDeclsWithMode, parseHsType, parseHsExp, parseHsPat, pprHsModule, moduleDecls, noSrcSpanInfo, emptyHsModule ) where import Language.Haskell.Exts.Extension import Language.Haskell.Exts.Parser hiding (parseExp, parsePat, parseType) import Language.Haskell.Exts.Pretty import qualified Language.Haskell.Exts.SrcLoc as Hs import qualified Language.Haskell.Exts.Syntax as Hs import Language.Haskell.Meta.Syntax.Translate import Language.Haskell.TH.Syntax hiding (Extension (..)) ----------------------------------------------------------------------------- -- * 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 -- | @since 0.8.2 parseDecsWithMode :: ParseMode -> String -> Either String [Dec] parseDecsWithMode parseMode = either Left (Right . toDecs) . parseHsDeclsWithMode parseMode ----------------------------------------------------------------------------- {-# DEPRECATED myDefaultParseMode, myDefaultExtensions "The provided ParseModes aren't very meaningful, use your own instead" #-} myDefaultParseMode :: ParseMode myDefaultParseMode = defaultParseMode {parseFilename = [] ,baseLanguage = Haskell2010 ,extensions = map EnableExtension myDefaultExtensions } myDefaultExtensions :: [KnownExtension] myDefaultExtensions = [PostfixOperators ,QuasiQuotes ,UnicodeSyntax ,PatternSignatures ,MagicHash ,ForeignFunctionInterface ,TemplateHaskell ,RankNTypes ,MultiParamTypeClasses ,RecursiveDo ,TypeApplications] parseResultToEither :: ParseResult a -> Either String a parseResultToEither (ParseOk a) = Right a parseResultToEither (ParseFailed loc e) = let line = Hs.srcLine loc - 1 in Left (unlines [show line,show loc,e]) parseHsModule :: String -> Either String (Hs.Module Hs.SrcSpanInfo) parseHsModule = parseResultToEither . parseModuleWithMode myDefaultParseMode parseHsDecls :: String -> Either String [Hs.Decl Hs.SrcSpanInfo] parseHsDecls = either Left (Right . moduleDecls) . parseResultToEither . parseModuleWithMode myDefaultParseMode -- | @since 0.8.2 parseHsDeclsWithMode :: ParseMode -> String -> Either String [Hs.Decl Hs.SrcSpanInfo] parseHsDeclsWithMode parseMode = either Left (Right . moduleDecls) . parseResultToEither . parseModuleWithMode parseMode parseHsType :: String -> Either String (Hs.Type Hs.SrcSpanInfo) parseHsType = parseResultToEither . parseTypeWithMode myDefaultParseMode parseHsExp :: String -> Either String (Hs.Exp Hs.SrcSpanInfo) parseHsExp = parseResultToEither . parseExpWithMode myDefaultParseMode parseHsPat :: String -> Either String (Hs.Pat Hs.SrcSpanInfo) parseHsPat = parseResultToEither . parsePatWithMode myDefaultParseMode pprHsModule :: Hs.Module Hs.SrcSpanInfo -> String pprHsModule = prettyPrint moduleDecls :: Hs.Module Hs.SrcSpanInfo -> [Hs.Decl Hs.SrcSpanInfo] moduleDecls (Hs.Module _ _ _ _ x) = x moduleDecls m = todo "" m -- TODO -- (Hs.XmlPage _ _ _ _ _ _ _) -- (Hs.XmlHybrid _ _ _ _ _ _ _ _ _) -- mkModule :: String -> Hs.Module -- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] [] emptyHsModule :: String -> Hs.Module Hs.SrcSpanInfo emptyHsModule n = (Hs.Module noSrcSpanInfo (Just (Hs.ModuleHead noSrcSpanInfo (Hs.ModuleName noSrcSpanInfo n) Nothing Nothing)) [] [] []) noSrcSpanInfo :: Hs.SrcSpanInfo noSrcSpanInfo = Hs.noInfoSpan (Hs.mkSrcSpan Hs.noLoc Hs.noLoc) {- ghci> :i Module data Module = Module SrcLoc ModuleName [OptionPragma] (Maybe WarningText) (Maybe [ExportSpec]) [ImportDecl] [Decl] -- Defined in Language.Haskell.Exts.Syntax instance Show Module -- Defined in Language.Haskell.Exts.Syntax -} ----------------------------------------------------------------------------- haskell-src-meta-0.8.12/src/Language/Haskell/Meta/Syntax/0000755000000000000000000000000007346545000021200 5ustar0000000000000000haskell-src-meta-0.8.12/src/Language/Haskell/Meta/Syntax/Translate.hs0000644000000000000000000007525707346545000023511 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {- | 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 , TyVarBndr_ ) where import qualified Data.Char as Char import qualified Data.List as List import qualified Language.Haskell.Exts.SrcLoc as Exts.SrcLoc import qualified Language.Haskell.Exts.Syntax as Exts import Language.Haskell.Meta.THCompat (TyVarBndr_) import qualified Language.Haskell.Meta.THCompat as Compat import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH ----------------------------------------------------------------------------- class ToName a where toName :: a -> TH.Name class ToNames a where toNames :: a -> [TH.Name] class ToLit a where toLit :: a -> TH.Lit class ToType a where toType :: a -> TH.Type class ToPat a where toPat :: a -> TH.Pat class ToExp a where toExp :: a -> TH.Exp class ToDecs a where toDecs :: a -> [TH.Dec] class ToDec a where toDec :: a -> TH.Dec class ToStmt a where toStmt :: a -> TH.Stmt class ToLoc a where toLoc :: a -> TH.Loc class ToCxt a where toCxt :: a -> TH.Cxt class ToPred a where toPred :: a -> TH.Pred class ToTyVars a where toTyVars :: a -> [TyVarBndr_ ()] class ToMaybeKind a where toMaybeKind :: a -> Maybe TH.Kind class ToInjectivityAnn a where toInjectivityAnn :: a -> TH.InjectivityAnn type DerivClause = TH.DerivClause class ToDerivClauses a where toDerivClauses :: a -> [DerivClause] -- for error messages moduleName :: String moduleName = "Language.Haskell.Meta.Syntax.Translate" -- When to use each of these isn't always clear: prefer 'todo' if unsure. noTH :: (Functor f, Show (f ())) => String -> f e -> a noTH fun thing = error . concat $ [moduleName, ".", fun, ": template-haskell has no representation for: ", show (fmap (const ()) thing)] noTHyet :: (Functor f, Show (f ())) => String -> String -> f e -> a noTHyet fun minVersion thing = error . concat $ [moduleName, ".", fun, ": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")", " has no representation for: ", show (fmap (const ()) thing)] todo :: (Functor f, Show (f ())) => String -> f e -> a todo fun thing = error . concat $ [moduleName, ".", fun, ": not implemented: ", show (fmap (const ()) thing)] nonsense :: (Functor f, Show (f ())) => String -> String -> f e -> a nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun, ": nonsensical: ", inparticular, ": ", show (fmap (const ()) thing)] #if MIN_VERSION_template_haskell(2,16,0) toTupEl :: ToExp a => a -> Maybe TH.Exp toTupEl = Just . toExp #else toTupEl :: ToExp a => a -> TH.Exp toTupEl = toExp #endif ----------------------------------------------------------------------------- instance ToExp TH.Lit where toExp = TH.LitE instance (ToExp a) => ToExp [a] where toExp = TH.ListE . fmap toExp instance (ToExp a, ToExp b) => ToExp (a,b) where toExp (a,b) = TH.TupE [toTupEl a, toTupEl b] instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where toExp (a,b,c) = TH.TupE [toTupEl a, toTupEl b, toTupEl c] instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where toExp (a,b,c,d) = TH.TupE [toTupEl a, toTupEl b, toTupEl c, toTupEl d] instance ToPat TH.Lit where toPat = TH.LitP instance (ToPat a) => ToPat [a] where toPat = TH.ListP . fmap toPat instance (ToPat a, ToPat b) => ToPat (a,b) where toPat (a,b) = TH.TupP [toPat a, toPat b] instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where toPat (a,b,c) = TH.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) = TH.TupP [toPat a, toPat b, toPat c, toPat d] instance ToLit Char where toLit = TH.CharL instance ToLit String where toLit = TH.StringL instance ToLit Integer where toLit = TH.IntegerL instance ToLit Int where toLit = TH.IntegerL . toInteger instance ToLit Float where toLit = TH.RationalL . toRational instance ToLit Double where toLit = TH.RationalL . toRational ----------------------------------------------------------------------------- -- * ToName {String,HsName,Module,HsSpecialCon,HsQName} instance ToName String where toName = TH.mkName instance ToName (Exts.Name l) where toName (Exts.Ident _ s) = toName s toName (Exts.Symbol _ s) = toName s instance ToName (Exts.SpecialCon l) where toName (Exts.UnitCon _) = TH.mkName "()" -- TODO LumiGuide: '() toName (Exts.ListCon _) = ''[] -- Parser only uses this in types -- TODO LumiGuide: '[] toName (Exts.FunCon _) = ''(->) toName (Exts.TupleCon _ _ n) = TH.mkName $ concat ["(",replicate (n-1) ',',")"] -- TODO LumiGuide: -- . -- .| n<2 = '() -- .| otherwise = -- . let x = maybe [] (++".") (nameModule '(,)) -- . in TH.mkName . concat $ x : ["(",replicate (n-1) ',',")"] toName (Exts.Cons _) = '(:) toName h = todo "toName not implemented" h -- TODO -- toName (Exts.UnboxedSingleCon _) = '' -- toName (Exts.ExprHole _) = ''_ instance ToName (Exts.QName l) where -- TODO: why is this commented out? -- toName (Exts.Qual (Exts.Module []) n) = toName n toName (Exts.Qual _ (Exts.ModuleName _ []) n) = toName n toName (Exts.Qual _ (Exts.ModuleName _ m) n) = let m' = show . toName $ m n' = show . toName $ n in toName . concat $ [m',".",n'] toName (Exts.UnQual _ n) = toName n toName (Exts.Special _ s) = toName s #if MIN_VERSION_haskell_src_exts(1,20,1) instance ToName (Exts.MaybePromotedName l) where toName (Exts.PromotedName _ qn) = toName qn toName (Exts.UnpromotedName _ qn) = toName qn #endif instance ToName (Exts.Op l) where toName (Exts.VarOp _ n) = toName n toName (Exts.ConOp _ n) = toName n ----------------------------------------------------------------------------- -- * ToLit HsLiteral instance ToLit (Exts.Literal l) where toLit (Exts.Char _ a _) = TH.CharL a toLit (Exts.String _ a _) = TH.StringL a toLit (Exts.Int _ a _) = TH.IntegerL a toLit (Exts.Frac _ a _) = TH.RationalL a toLit l@Exts.PrimChar{} = noTH "toLit" l toLit (Exts.PrimString _ a _) = TH.StringPrimL (map toWord8 a) where toWord8 = fromIntegral . Char.ord toLit (Exts.PrimInt _ a _) = TH.IntPrimL a toLit (Exts.PrimFloat _ a _) = TH.FloatPrimL a toLit (Exts.PrimDouble _ a _) = TH.DoublePrimL a toLit (Exts.PrimWord _ a _) = TH.WordPrimL a ----------------------------------------------------------------------------- -- * ToPat HsPat instance ToPat (Exts.Pat l) where toPat (Exts.PVar _ n) = TH.VarP (toName n) toPat (Exts.PLit _ (Exts.Signless _) l) = TH.LitP (toLit l) toPat (Exts.PLit _ (Exts.Negative _) l) = TH.LitP $ case toLit l of TH.IntegerL z -> TH.IntegerL (negate z) TH.RationalL q -> TH.RationalL (negate q) TH.IntPrimL z' -> TH.IntPrimL (negate z') TH.FloatPrimL r' -> TH.FloatPrimL (negate r') TH.DoublePrimL r'' -> TH.DoublePrimL (negate r'') _ -> nonsense "toPat" "negating wrong kind of literal" l toPat (Exts.PInfixApp _ p n q) = TH.UInfixP (toPat p) (toName n) (toPat q) toPat (Exts.PApp _ n ps) = Compat.conP (toName n) (fmap toPat ps) toPat (Exts.PTuple _ Exts.Boxed ps) = TH.TupP (fmap toPat ps) toPat (Exts.PTuple _ Exts.Unboxed ps) = TH.UnboxedTupP (fmap toPat ps) toPat (Exts.PList _ ps) = TH.ListP (fmap toPat ps) toPat (Exts.PParen _ p) = TH.ParensP (toPat p) -- TODO: move toFieldPat to top level defn toPat (Exts.PRec _ n pfs) = let toFieldPat (Exts.PFieldPat _ n' p) = (toName n', toPat p) toFieldPat h = todo "toFieldPat" h in TH.RecP (toName n) (fmap toFieldPat pfs) toPat (Exts.PAsPat _ n p) = TH.AsP (toName n) (toPat p) toPat (Exts.PWildCard _) = TH.WildP toPat (Exts.PIrrPat _ p) = TH.TildeP (toPat p) toPat (Exts.PatTypeSig _ p t) = TH.SigP (toPat p) (toType t) toPat (Exts.PViewPat _ e p) = TH.ViewP (toExp e) (toPat p) -- regular pattern toPat p@Exts.PRPat{} = noTH "toPat" p -- XML stuff toPat p@Exts.PXTag{} = noTH "toPat" p toPat p@Exts.PXETag{} = noTH "toPat" p toPat p@Exts.PXPcdata{} = noTH "toPat" p toPat p@Exts.PXPatTag{} = noTH "toPat" p toPat (Exts.PBangPat _ p) = TH.BangP (toPat p) toPat p = todo "toPat" p -- TODO -- (Exts.PNPlusK _ _ _) -- (Exts.PUnboxedSum _ _ _ _) -- (Exts.PXRPats _ _) -- (Exts.PSplice _ _) -- ... ----------------------------------------------------------------------------- -- * ToExp HsExp instance ToExp (Exts.QOp l) where toExp (Exts.QVarOp _ n) = TH.VarE (toName n) toExp (Exts.QConOp _ n) = TH.ConE (toName n) toFieldExp :: Exts.FieldUpdate l -> TH.FieldExp toFieldExp (Exts.FieldUpdate _ n e) = (toName n, toExp e) toFieldExp h = todo "toFieldExp" h instance ToExp (Exts.Exp l) where toExp (Exts.Var _ n) = TH.VarE (toName n) toExp e@Exts.IPVar{} = noTH "toExp" e toExp (Exts.Con _ n) = TH.ConE (toName n) toExp (Exts.Lit _ l) = TH.LitE (toLit l) #if MIN_VERSION_template_haskell(2,13,0) toExp (Exts.OverloadedLabel _ s) = TH.LabelE s #endif toExp (Exts.InfixApp _ e o f) = TH.UInfixE (toExp e) (toExp o) (toExp f) toExp (Exts.App _ e (Exts.TypeApp _ t)) = TH.AppTypeE (toExp e) (toType t) toExp (Exts.App _ e f) = TH.AppE (toExp e) (toExp f) toExp (Exts.NegApp _ e) = TH.AppE (TH.VarE 'negate) (toExp e) toExp (Exts.Lambda _ ps e) = TH.LamE (fmap toPat ps) (toExp e) toExp (Exts.Let _ bs e) = TH.LetE (toDecs bs) (toExp e) toExp (Exts.If _ a b c) = TH.CondE (toExp a) (toExp b) (toExp c) toExp (Exts.MultiIf _ ifs) = TH.MultiIfE (map toGuard ifs) toExp (Exts.Case _ e alts) = TH.CaseE (toExp e) (map toMatch alts) #if MIN_VERSION_template_haskell(2,17,0) toExp (Exts.Do _ ss) = TH.DoE Nothing (map toStmt ss) #else toExp (Exts.Do _ ss) = TH.DoE (map toStmt ss) #endif toExp e@Exts.MDo{} = noTH "toExp" e toExp (Exts.Tuple _ Exts.Boxed xs) = TH.TupE (fmap toTupEl xs) toExp (Exts.Tuple _ Exts.Unboxed xs) = TH.UnboxedTupE (fmap toTupEl xs) toExp e@Exts.TupleSection{} = noTH "toExp" e toExp (Exts.List _ xs) = TH.ListE (fmap toExp xs) toExp (Exts.Paren _ e) = TH.ParensE (toExp e) toExp (Exts.LeftSection _ e o) = TH.InfixE (Just . toExp $ e) (toExp o) Nothing toExp (Exts.RightSection _ o f) = TH.InfixE Nothing (toExp o) (Just . toExp $ f) toExp (Exts.RecConstr _ n xs) = TH.RecConE (toName n) (fmap toFieldExp xs) toExp (Exts.RecUpdate _ e xs) = TH.RecUpdE (toExp e) (fmap toFieldExp xs) toExp (Exts.EnumFrom _ e) = TH.ArithSeqE $ TH.FromR (toExp e) toExp (Exts.EnumFromTo _ e f) = TH.ArithSeqE $ TH.FromToR (toExp e) (toExp f) toExp (Exts.EnumFromThen _ e f) = TH.ArithSeqE $ TH.FromThenR (toExp e) (toExp f) toExp (Exts.EnumFromThenTo _ e f g) = TH.ArithSeqE $ TH.FromThenToR (toExp e) (toExp f) (toExp g) toExp (Exts.ListComp _ e ss) = TH.CompE $ map convert ss ++ [TH.NoBindS (toExp e)] where convert (Exts.QualStmt _ st) = toStmt st convert s = noTH "toExp ListComp" s toExp (Exts.ExpTypeSig _ e t) = TH.SigE (toExp e) (toType t) toExp e = todo "toExp" e toMatch :: Exts.Alt l -> TH.Match toMatch (Exts.Alt _ p rhs ds) = TH.Match (toPat p) (toBody rhs) (toDecs ds) toBody :: Exts.Rhs l -> TH.Body toBody (Exts.UnGuardedRhs _ e) = TH.NormalB $ toExp e toBody (Exts.GuardedRhss _ rhss) = TH.GuardedB $ map toGuard rhss toGuard :: Exts.GuardedRhs l -> (TH.Guard, TH.Exp) toGuard (Exts.GuardedRhs _ stmts e) = (g, toExp e) where g = case map toStmt stmts of [TH.NoBindS x] -> TH.NormalG x xs -> TH.PatG xs instance ToDecs a => ToDecs (Maybe a) where toDecs Nothing = [] toDecs (Just a) = toDecs a instance ToDecs (Exts.Binds l) where toDecs (Exts.BDecls _ ds) = toDecs ds toDecs a@(Exts.IPBinds {}) = noTH "ToDecs Exts.Binds" a instance ToDecs (Exts.ClassDecl l) where toDecs (Exts.ClsDecl _ d) = toDecs d toDecs x = todo "classDecl" x ----------------------------------------------------------------------------- -- * ToLoc SrcLoc instance ToLoc Exts.SrcLoc.SrcLoc where toLoc (Exts.SrcLoc.SrcLoc fn l c) = TH.Loc fn [] [] (l,c) (-1,-1) ----------------------------------------------------------------------------- -- * ToType HsType instance ToName (Exts.TyVarBind l) where toName (Exts.KindedVar _ n _) = toName n toName (Exts.UnkindedVar _ n) = toName n instance ToName TH.Name where toName = id instance ToName (Compat.TyVarBndr_ flag) where #if MIN_VERSION_template_haskell(2,17,0) toName (TH.PlainTV n _) = n toName (TH.KindedTV n _ _) = n #else toName (TH.PlainTV n) = n toName (TH.KindedTV n _) = n #endif #if !MIN_VERSION_haskell_src_exts(1,21,0) instance ToType (Exts.Kind l) where toType (Exts.KindStar _) = TH.StarT toType (Exts.KindFn _ k1 k2) = toType k1 .->. toType k2 toType (Exts.KindParen _ kp) = toType kp toType (Exts.KindVar _ n) = TH.VarT (toName n) -- TODO LumiGuide: -- toType (Hs.KindVar _ n) -- | isCon (nameBase th_n) = ConT th_n -- | otherwise = VarT th_n -- where -- th_n = toName n -- -- isCon :: String -> Bool -- isCon (c:_) = isUpper c || c == ':' -- isCon _ = nonsense "toType" "empty kind variable name" n toType (Exts.KindApp _ k1 k2) = toType k1 `TH.AppT` toType k2 toType (Exts.KindTuple _ ks) = foldr (\k pt -> pt `TH.AppT` toType k) (TH.TupleT $ length ks) ks toType (Exts.KindList _ k) = TH.ListT `TH.AppT` toType k #endif toKind :: Exts.Kind l -> TH.Kind toKind = toType toTyVar :: Exts.TyVarBind l -> TyVarBndr_ () #if MIN_VERSION_template_haskell(2,17,0) toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) () (toKind k) toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n) () #else toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) (toKind k) toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n) #endif #if MIN_VERSION_template_haskell(2,17,0) toTyVarSpec :: TyVarBndr_ () -> TH.TyVarBndrSpec toTyVarSpec (TH.KindedTV n () k) = TH.KindedTV n TH.SpecifiedSpec k toTyVarSpec (TH.PlainTV n ()) = TH.PlainTV n TH.SpecifiedSpec #else toTyVarSpec :: TyVarBndr_ flag -> TyVarBndr_ flag toTyVarSpec = id #endif instance ToType (Exts.Type l) where toType (Exts.TyForall _ tvbM cxt t) = TH.ForallT (maybe [] (fmap (toTyVarSpec . toTyVar)) tvbM) (toCxt cxt) (toType t) toType (Exts.TyFun _ a b) = toType a .->. toType b toType (Exts.TyList _ t) = TH.ListT `TH.AppT` toType t toType (Exts.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts) where tuple = case b of Exts.Boxed -> TH.TupleT Exts.Unboxed -> TH.UnboxedTupleT toType (Exts.TyApp _ a b) = TH.AppT (toType a) (toType b) toType (Exts.TyVar _ n) = TH.VarT (toName n) toType (Exts.TyCon _ qn) = TH.ConT (toName qn) toType (Exts.TyParen _ t) = toType t -- XXX: need to wrap the name in parens! #if MIN_VERSION_haskell_src_exts(1,20,0) -- TODO: why does this branch exist? -- Why fail toType if this is a promoted name? toType (Exts.TyInfix _ a (Exts.UnpromotedName _ o) b) = TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b) #else toType (Exts.TyInfix _ a o b) = TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b) #endif toType (Exts.TyKind _ t k) = TH.SigT (toType t) (toKind k) toType (Exts.TyPromoted _ p) = case p of Exts.PromotedInteger _ i _ -> TH.LitT $ TH.NumTyLit i Exts.PromotedString _ _ s -> TH.LitT $ TH.StrTyLit s Exts.PromotedCon _ _q n -> TH.PromotedT $ toName n Exts.PromotedList _ _q ts -> foldr (\t pl -> TH.PromotedConsT `TH.AppT` toType t `TH.AppT` pl) TH.PromotedNilT ts Exts.PromotedTuple _ ts -> foldl (\pt t -> pt `TH.AppT` toType t) (TH.PromotedTupleT $ length ts) ts Exts.PromotedUnit _ -> TH.PromotedT ''() toType (Exts.TyEquals _ t1 t2) = TH.EqualityT `TH.AppT` toType t1 `TH.AppT` toType t2 toType t@Exts.TySplice{} = noTH "toType" t toType t@Exts.TyBang{} = nonsense "toType" "type cannot have strictness annotations in this context" t toType t@Exts.TyWildCard{} = noTH "toType" t toType t = todo "toType" t -- TODO -- toType (Exts.TyUnboxedSum _ _) -- toType (Exts.TyParArray _ _) -- toType (Exts.TyInfix _ _ (Exts.PromotedName _ _) _) toStrictType :: Exts.Type l -> TH.StrictType toStrictType (Exts.TyBang _ s u t) = (TH.Bang (toUnpack u) (toStrict s), toType t) where toStrict (Exts.LazyTy _) = TH.SourceLazy toStrict (Exts.BangedTy _) = TH.SourceStrict toStrict (Exts.NoStrictAnnot _) = TH.NoSourceStrictness toUnpack (Exts.Unpack _) = TH.SourceUnpack toUnpack (Exts.NoUnpack _) = TH.SourceNoUnpack toUnpack (Exts.NoUnpackPragma _) = TH.NoSourceUnpackedness toStrictType x = (TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness, toType x) (.->.) :: TH.Type -> TH.Type -> TH.Type a .->. b = TH.AppT (TH.AppT TH.ArrowT a) b instance ToPred (Exts.Asst l) where #if MIN_VERSION_haskell_src_exts(1,22,0) toPred (Exts.TypeA _ t) = toType t #else toPred (Exts.ClassA _ n ts) = List.foldl' TH.AppT (TH.ConT (toName n)) (fmap toType ts) toPred (Exts.InfixA _ t1 n t2) = List.foldl' TH.AppT (TH.ConT (toName n)) (fmap toType [t1,t2]) toPred (Exts.EqualP _ t1 t2) = List.foldl' TH.AppT TH.EqualityT (fmap toType [t1,t2]) toPred a@Exts.AppA{} = todo "toPred" a toPred a@Exts.WildCardA{} = todo "toPred" a #endif toPred (Exts.ParenA _ asst) = toPred asst toPred a@Exts.IParam{} = noTH "toPred" a -- Pattern match is redundant. -- TODO: Is there a way to turn off this warn for catch-alls? -- would make the code more future-compat -- toPred p = todo "toPred" p instance ToDerivClauses (Exts.Deriving l) where #if MIN_VERSION_haskell_src_exts(1,20,0) toDerivClauses (Exts.Deriving _ strat irules) = [TH.DerivClause (fmap toDerivStrategy strat) (map toType irules)] #else toDerivClauses (Exts.Deriving _ irules) = [TH.DerivClause Nothing (map toType irules)] #endif instance ToDerivClauses a => ToDerivClauses (Maybe a) where toDerivClauses Nothing = [] toDerivClauses (Just a) = toDerivClauses a instance ToDerivClauses a => ToDerivClauses [a] where toDerivClauses = concatMap toDerivClauses toDerivStrategy :: (Exts.DerivStrategy l) -> TH.DerivStrategy toDerivStrategy (Exts.DerivStock _) = TH.StockStrategy toDerivStrategy (Exts.DerivAnyclass _) = TH.AnyclassStrategy toDerivStrategy (Exts.DerivNewtype _) = TH.NewtypeStrategy #if MIN_VERSION_haskell_src_exts(1,21,0) && MIN_VERSION_template_haskell(2,14,0) toDerivStrategy (Exts.DerivVia _ t) = TH.ViaStrategy (toType t) #else toDerivStrategy d@Exts.DerivVia{} = noTHyet "toDerivStrategy" "2.14" d #endif -- TODO LumiGuide -- instance ToCxt (Hs.Deriving l) where -- #if MIN_VERSION_haskell_src_exts(1,20,1) -- toCxt (Hs.Deriving _ _ rule) = toCxt rule -- #else -- toCxt (Hs.Deriving _ rule) = toCxt rule -- #endif -- instance ToCxt [Hs.InstRule l] where -- toCxt = concatMap toCxt -- instance ToCxt a => ToCxt (Maybe a) where -- toCxt Nothing = [] -- toCxt (Just a) = toCxt a foldAppT :: TH.Type -> [TH.Type] -> TH.Type foldAppT t ts = List.foldl' TH.AppT t ts ----------------------------------------------------------------------------- -- * ToStmt HsStmt instance ToStmt (Exts.Stmt l) where toStmt (Exts.Generator _ p e) = TH.BindS (toPat p) (toExp e) toStmt (Exts.Qualifier _ e) = TH.NoBindS (toExp e) toStmt _a@(Exts.LetStmt _ bnds) = TH.LetS (toDecs bnds) toStmt s@Exts.RecStmt{} = noTH "toStmt" s ----------------------------------------------------------------------------- -- * ToDec HsDecl instance ToDec (Exts.Decl l) where toDec (Exts.TypeDecl _ h t) = TH.TySynD (toName h) (toTyVars h) (toType t) toDec a@(Exts.DataDecl _ dOrN cxt h qcds qns) = case dOrN of Exts.DataType _ -> TH.DataD (toCxt cxt) (toName h) (toTyVars h) Nothing (fmap qualConDeclToCon qcds) (toDerivClauses qns) Exts.NewType _ -> let qcd = case qcds of [x] -> x _ -> nonsense "toDec" ("newtype with " ++ "wrong number of constructors") a in TH.NewtypeD (toCxt cxt) (toName h) (toTyVars h) Nothing (qualConDeclToCon qcd) (toDerivClauses qns) -- This type-signature conversion is just wrong. -- Type variables need to be dealt with. /Jonas toDec _a@(Exts.TypeSig _ ns t) -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class! = let xs = fmap (flip TH.SigD (toType t) . toName) ns in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!" toDec (Exts.InlineConlikeSig _ act qn) = TH.PragmaD $ TH.InlineP (toName qn) TH.Inline TH.ConLike (transAct act) toDec (Exts.InlineSig _ b act qn) = TH.PragmaD $ TH.InlineP (toName qn) inline TH.FunLike (transAct act) where inline | b = TH.Inline | otherwise = TH.NoInline toDec (Exts.TypeFamDecl _ h sig inj) = TH.OpenTypeFamilyD $ TH.TypeFamilyHead (toName h) (toTyVars h) (maybe TH.NoSig TH.KindSig . toMaybeKind $ sig) (fmap toInjectivityAnn inj) toDec (Exts.DataFamDecl _ _ h sig) = TH.DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig) toDec _a@(Exts.FunBind _ mtchs) = hsMatchesToFunD mtchs toDec (Exts.PatBind _ p rhs bnds) = TH.ValD (toPat p) (hsRhsToBody rhs) (toDecs bnds) toDec i@(Exts.InstDecl _ (Just overlap) _ _) = noTH "toDec" (fmap (const ()) overlap, i) -- the 'vars' bit seems to be for: instance forall a. C (T a) where ... -- TH's own parser seems to flat-out ignore them, and honestly I can't see -- that it's obviously wrong to do so. toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD Nothing (toCxt irule) (toType irule) (toDecs ids) toDec (Exts.ClassDecl _ cxt h fds decls) = TH.ClassD (toCxt cxt) (toName h) (toTyVars h) (fmap toFunDep fds) (toDecs decls) where toFunDep (Exts.FunDep _ ls rs) = TH.FunDep (fmap toName ls) (fmap toName rs) toDec (Exts.AnnPragma _ ann) = TH.PragmaD (TH.AnnP (target ann) (expann ann)) where target (Exts.Ann _ n _) = TH.ValueAnnotation (toName n) target (Exts.TypeAnn _ n _) = TH.TypeAnnotation (toName n) target (Exts.ModuleAnn _ _) = TH.ModuleAnnotation expann (Exts.Ann _ _ e) = toExp e expann (Exts.TypeAnn _ _ e) = toExp e expann (Exts.ModuleAnn _ e) = toExp e toDec x = todo "toDec" x instance ToMaybeKind (Exts.ResultSig l) where toMaybeKind (Exts.KindSig _ k) = Just $ toKind k toMaybeKind (Exts.TyVarSig _ _) = Nothing instance ToMaybeKind a => ToMaybeKind (Maybe a) where toMaybeKind Nothing = Nothing toMaybeKind (Just a) = toMaybeKind a instance ToInjectivityAnn (Exts.InjectivityInfo l) where toInjectivityAnn (Exts.InjectivityInfo _ n ns) = TH.InjectivityAnn (toName n) (fmap toName ns) transAct :: Maybe (Exts.Activation l) -> TH.Phases transAct Nothing = TH.AllPhases transAct (Just (Exts.ActiveFrom _ n)) = TH.FromPhase n transAct (Just (Exts.ActiveUntil _ n)) = TH.BeforePhase n instance ToName (Exts.DeclHead l) where toName (Exts.DHead _ n) = toName n toName (Exts.DHInfix _ _ n) = toName n toName (Exts.DHParen _ h) = toName h toName (Exts.DHApp _ h _) = toName h instance ToTyVars (Exts.DeclHead l) where toTyVars (Exts.DHead _ _) = [] toTyVars (Exts.DHParen _ h) = toTyVars h toTyVars (Exts.DHInfix _ tvb _) = [toTyVar tvb] toTyVars (Exts.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb] instance ToNames a => ToNames (Maybe a) where toNames Nothing = [] toNames (Just a) = toNames a instance ToNames (Exts.Deriving l) where #if MIN_VERSION_haskell_src_exts(1,20,0) toNames (Exts.Deriving _ _ irules) = concatMap toNames irules #else toNames (Exts.Deriving _ irules) = concatMap toNames irules #endif instance ToNames (Exts.InstRule l) where toNames (Exts.IParen _ irule) = toNames irule toNames (Exts.IRule _ _mtvbs _mcxt mihd) = toNames mihd instance ToNames (Exts.InstHead l) where toNames (Exts.IHCon _ n) = [toName n] toNames (Exts.IHInfix _ _ n) = [toName n] toNames (Exts.IHParen _ h) = toNames h toNames (Exts.IHApp _ h _) = toNames h instance ToCxt (Exts.InstRule l) where toCxt (Exts.IRule _ _ cxt _) = toCxt cxt toCxt (Exts.IParen _ irule) = toCxt irule instance ToCxt (Exts.Context l) where toCxt x = case x of Exts.CxEmpty _ -> [] Exts.CxSingle _ x' -> [toPred x'] Exts.CxTuple _ xs -> fmap toPred xs instance ToCxt a => ToCxt (Maybe a) where toCxt Nothing = [] toCxt (Just a) = toCxt a instance ToType (Exts.InstRule l) where toType (Exts.IRule _ _ _ h) = toType h toType (Exts.IParen _ irule) = toType irule instance ToType (Exts.InstHead l) where toType (Exts.IHCon _ qn) = toType qn toType (Exts.IHInfix _ typ qn) = TH.AppT (toType typ) (toType qn) toType (Exts.IHParen _ hd) = toType hd toType (Exts.IHApp _ hd typ) = TH.AppT (toType hd) (toType typ) qualConDeclToCon :: Exts.QualConDecl l -> TH.Con qualConDeclToCon (Exts.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl qualConDeclToCon (Exts.QualConDecl _ ns cxt cdecl) = TH.ForallC (toTyVarSpec <$> toTyVars ns) (toCxt cxt) (conDeclToCon cdecl) instance ToTyVars a => ToTyVars (Maybe a) where toTyVars Nothing = [] toTyVars (Just a) = toTyVars a instance ToTyVars a => ToTyVars [a] where toTyVars = concatMap toTyVars instance ToTyVars (Exts.TyVarBind l) where toTyVars tvb = [toTyVar tvb] instance ToType (Exts.QName l) where toType = TH.ConT . toName conDeclToCon :: Exts.ConDecl l -> TH.Con conDeclToCon (Exts.ConDecl _ n tys) = TH.NormalC (toName n) (map toStrictType tys) conDeclToCon (Exts.RecDecl _ n fieldDecls) = TH.RecC (toName n) (concatMap convField fieldDecls) where convField :: Exts.FieldDecl l -> [TH.VarStrictType] convField (Exts.FieldDecl _ ns t) = let (strict, ty) = toStrictType t in map (\n' -> (toName n', strict, ty)) ns conDeclToCon h = todo "conDeclToCon" h -- TODO -- (Exts.InfixConDecl _ _ _ _) hsMatchesToFunD :: [Exts.Match l] -> TH.Dec hsMatchesToFunD [] = TH.FunD (TH.mkName []) [] -- errorish hsMatchesToFunD xs@(Exts.Match _ n _ _ _ : _) = TH.FunD (toName n) (fmap hsMatchToClause xs) hsMatchesToFunD xs@(Exts.InfixMatch _ _ n _ _ _ : _) = TH.FunD (toName n) (fmap hsMatchToClause xs) hsMatchToClause :: Exts.Match l -> TH.Clause hsMatchToClause (Exts.Match _ _ ps rhs bnds) = TH.Clause (fmap toPat ps) (hsRhsToBody rhs) (toDecs bnds) hsMatchToClause (Exts.InfixMatch _ p _ ps rhs bnds) = TH.Clause (fmap toPat (p:ps)) (hsRhsToBody rhs) (toDecs bnds) hsRhsToBody :: Exts.Rhs l -> TH.Body hsRhsToBody (Exts.UnGuardedRhs _ e) = TH.NormalB (toExp e) hsRhsToBody (Exts.GuardedRhss _ hsgrhs) = let fromGuardedB (TH.GuardedB a) = a fromGuardedB h = todo "fromGuardedB" [h] -- TODO: (NormalB _) in TH.GuardedB . concat . fmap (fromGuardedB . hsGuardedRhsToBody) $ hsgrhs hsGuardedRhsToBody :: Exts.GuardedRhs l -> TH.Body hsGuardedRhsToBody (Exts.GuardedRhs _ [] e) = TH.NormalB (toExp e) hsGuardedRhsToBody (Exts.GuardedRhs _ [s] e) = TH.GuardedB [(hsStmtToGuard s, toExp e)] hsGuardedRhsToBody (Exts.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss (pgs,ngs) = unzip [(p,n) | (TH.PatG p) <- ss' , n@(TH.NormalG _) <- ss'] e' = toExp e patg = TH.PatG (concat pgs) in TH.GuardedB $ (patg,e') : zip ngs (repeat e') hsStmtToGuard :: Exts.Stmt l -> TH.Guard hsStmtToGuard (Exts.Generator _ p e) = TH.PatG [TH.BindS (toPat p) (toExp e)] hsStmtToGuard (Exts.Qualifier _ e) = TH.NormalG (toExp e) hsStmtToGuard (Exts.LetStmt _ bs) = TH.PatG [TH.LetS (toDecs bs)] hsStmtToGuard h = todo "hsStmtToGuard" h -- TODO -- (Exts.RecStmt _ _) ----------------------------------------------------------------------------- -- * ToDecs InstDecl instance ToDecs (Exts.InstDecl l) where toDecs (Exts.InsDecl _ decl) = toDecs decl toDecs d = todo "toDec" d -- * ToDecs HsDecl HsBinds instance ToDecs (Exts.Decl l) where toDecs _a@(Exts.TypeSig _ ns t) -- TODO: fixforall as before? -- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns = let xs = fmap (flip TH.SigD (toType t) . toName) ns in xs toDecs (Exts.InfixDecl l assoc Nothing ops) = toDecs (Exts.InfixDecl l assoc (Just 9) ops) toDecs (Exts.InfixDecl _ assoc (Just fixity) ops) = map (\op -> TH.InfixD (TH.Fixity fixity dir) (toName op)) ops where dir = case assoc of Exts.AssocNone _ -> TH.InfixN Exts.AssocLeft _ -> TH.InfixL Exts.AssocRight _ -> TH.InfixR toDecs a = [toDec a] -- TODO: see aboe re: fixforall -- fixForall t@(TH.ForallT _ _ _) = t -- fixForall t = case vs of -- [] -> t -- _ -> TH.ForallT vs [] t -- where vs = collectVars t -- collectVars e = case e of -- VarT n -> [PlainTV n] -- AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2 -- TH.ForallT ns _ t -> collectVars t \\ ns -- _ -> [] instance ToDecs a => ToDecs [a] where toDecs a = concatMap toDecs a haskell-src-meta-0.8.12/src/Language/Haskell/Meta/THCompat.hs0000644000000000000000000000107707346545000021732 0ustar0000000000000000{-# LANGUAGE CPP #-} module Language.Haskell.Meta.THCompat ( module Language.Haskell.Meta.THCompat ) where import Language.Haskell.TH.Syntax conP :: Name -> [Pat] -> Pat #if MIN_VERSION_template_haskell(2,18,0) conP name = ConP name [] #else conP = ConP #endif #if MIN_VERSION_template_haskell(2,17,0) plainTV :: Name -> TyVarBndr Specificity plainTV n = PlainTV n SpecifiedSpec #else plainTV :: Name -> TyVarBndr plainTV = PlainTV #endif #if MIN_VERSION_template_haskell(2,17,0) type TyVarBndr_ flag = TyVarBndr flag #else type TyVarBndr_ flag = TyVarBndr #endif haskell-src-meta-0.8.12/src/Language/Haskell/Meta/Utils.hs0000644000000000000000000002740107346545000021352 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} -- | This module is a staging ground -- for to-be-organized-and-merged-nicely code. module Language.Haskell.Meta.Utils ( module Language.Haskell.Meta.Utils ) where import Control.Monad import Data.Generics hiding (Fixity) import Data.List (findIndex) import Language.Haskell.Exts.Pretty (prettyPrint) import Language.Haskell.Meta import qualified Language.Haskell.Meta.THCompat as Compat (conP, plainTV) import Language.Haskell.TH.Lib hiding (cxt) import Language.Haskell.TH.Ppr import Language.Haskell.TH.Syntax import System.IO.Unsafe (unsafePerformIO) import Text.PrettyPrint ----------------------------------------------------------------------------- dataDCons :: Dec -> [Con] dataDCons (DataD _ _ _ _ cons _) = cons dataDCons _ = [] decCons :: Dec -> [Con] decCons (DataD _ _ _ _ cons _) = cons decCons (NewtypeD _ _ _ _ con _) = [con] decCons _ = [] decTyVars :: Dec -> [TyVarBndr_ ()] 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 cleanNames :: (Data a) => a -> a cleanNames = everywhere (mkT cleanName) where cleanName :: Name -> Name cleanName n | isNameU n = n | otherwise = (mkName . nameBase) n isNameU :: Name -> Bool isNameU (Name _ (NameU _)) = True isNameU _ = False -- | The type passed in must have a @Show@ instance which -- produces a valid Haskell expression. Returns an empty -- @String@ if this is not the case. This is not TH-specific, -- but useful in general. pretty :: (Show a) => a -> String pretty a = case parseHsExp (show a) of Left _ -> [] Right e -> prettyPrint e pp :: (Data a, Ppr a) => a -> String pp = pprint . cleanNames ppDoc :: (Data a, Ppr a) => a -> Doc ppDoc = text . pp gpretty :: (Data a) => a -> String gpretty = either (const []) prettyPrint . parseHsExp . gshow instance Show ExpQ where show = show . cleanNames . unsafeRunQ instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unsafeRunQ instance Show DecQ where show = show . cleanNames . unsafeRunQ instance Show TypeQ where show = show . cleanNames . unsafeRunQ instance Show (Q String) where show = unsafeRunQ instance Show (Q Doc) where show = show . unsafeRunQ -- | @unsafeRunQ = unsafePerformIO . runQ@ unsafeRunQ :: Q a -> a unsafeRunQ = unsafePerformIO . runQ nameToRawCodeStr :: Name -> String nameToRawCodeStr n = let s = showNameParens n in case nameSpaceOf n of Just VarName -> "'"++s Just DataName -> "'"++s Just TcClsName -> "''"++s _ -> concat ["(mkName \"", filter (/='"') s, "\")"] where showNameParens :: Name -> String showNameParens n' = let nb = nameBase n' in case nb of (c:_) | isSym c -> concat ["(",nb,")"] _ -> nb isSym :: Char -> Bool isSym = (`elem` ("><.\\/!@#$%^&*-+?:|" :: [Char])) ----------------------------------------------------------------------------- (|$|) :: 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 :: (t1 -> t2 -> a1 -> (a2, t1, t2)) -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2) renameThings _ env new acc [] = (reverse acc, env, new) renameThings f env new acc (t:ts) = let (t', env', new') = f env new t in renameThings f env' new' (t':acc) ts -- | renameT applied to a list of types renameTs :: [(Name, Name)] -> [Name] -> [Type] -> [Type] -> ([Type], [(Name,Name)], [Name]) renameTs = renameThings renameT -- | Rename type variables in the Type according to the given association -- list. Normalise constructor names (remove qualification, etc.) -- If a name is not found in the association list, replace it with one from -- the fresh names list, and add this translation to the returned list. -- The fresh names list should be infinite; myNames is a good example. renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name]) renameT _env [] _ = error "renameT: ran out of names!" renameT env (x:new) (VarT n) | Just n' <- lookup n env = (VarT n',env,x:new) | otherwise = (VarT x, (n,x):env, new) renameT env new (ConT n) = (ConT (normaliseName n), env, new) renameT env new t@(TupleT {}) = (t,env,new) renameT env new ArrowT = (ArrowT,env,new) renameT env new ListT = (ListT,env,new) renameT env new (AppT t t') = let (s,env',new') = renameT env new t (s',env'',new'') = renameT env' new' t' in (AppT s s', env'', new'') renameT env new (ForallT ns cxt t) = let (ns',env2,new2) = renameTs env new [] (fmap (VarT . toName) ns) ns'' = fmap unVarT ns' (cxt',env3,new3) = renamePreds env2 new2 [] cxt (t',env4,new4) = renameT env3 new3 t in (ForallT ns'' cxt' t', env4, new4) where unVarT (VarT n) = Compat.plainTV n unVarT ty = error $ "renameT: unVarT: TODO for" ++ show ty renamePreds = renameThings renamePred renamePred = renameT renameT _ _ t = error $ "renameT: TODO for " ++ show t -- | Remove qualification, etc. normaliseName :: Name -> Name normaliseName = mkName . nameBase applyT :: Type -> Type -> Type applyT (ForallT [] _ t) t' = t `AppT` t' applyT (ForallT (n:ns) cxt t) t' = ForallT ns cxt (substT [(toName n,t')] (fmap toName ns) t) applyT t t' = t `AppT` t' substT :: [(Name, Type)] -> [Name] -> Type -> Type substT env bnd (ForallT ns _ t) = substT env (fmap toName ns++bnd) t substT env bnd t@(VarT n) | n `elem` bnd = t | otherwise = maybe t id (lookup n env) substT env bnd (AppT t t') = AppT (substT env bnd t) (substT env bnd t') substT _ _ t = t splitCon :: Con -> (Name,[Type]) splitCon c = (conName c, conTypes c) strictTypeTy :: StrictType -> Type strictTypeTy (_,t) = t varStrictTypeTy :: VarStrictType -> Type varStrictTypeTy (_,_,t) = t conTypes :: Con -> [Type] conTypes (NormalC _ sts) = fmap strictTypeTy sts conTypes (RecC _ vts) = fmap varStrictTypeTy vts conTypes (InfixC t _ t') = fmap strictTypeTy [t,t'] conTypes (ForallC _ _ c) = conTypes c conTypes c = error $ "conTypes: TODO for " ++ show c -- TODO -- (GadtC _ _ _) -- (RecGadtC _ _ _) conToConType :: Type -> Con -> Type conToConType ofType con = foldr (\a b -> AppT (AppT ArrowT a) b) ofType (conTypes con) 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 conName c = error $ "conName: TODO for" ++ show c -- TODO -- (GadtC _ _ _) -- (RecGadtC _ _ _) recCName :: Con -> Maybe Name recCName (RecC n _) = Just n recCName _ = Nothing fromDataConI :: Info -> Q (Maybe Exp) fromDataConI (DataConI dConN ty _tyConN) = let n = arityT ty in replicateM n (newName "a") >>= \ns -> return (Just (LamE [Compat.conP dConN (fmap VarP ns)] #if MIN_VERSION_template_haskell(2,16,0) (TupE $ fmap (Just . VarE) ns) #else (TupE $ fmap VarE ns) #endif )) fromDataConI _ = return Nothing fromTyConI :: Info -> Maybe Dec fromTyConI (TyConI dec) = Just dec fromTyConI _ = Nothing mkFunD :: Name -> [Pat] -> Exp -> Dec mkFunD f xs e = FunD f [Clause xs (NormalB e) []] mkClauseQ :: [PatQ] -> ExpQ -> ClauseQ mkClauseQ ps e = clause ps (normalB e) [] ----------------------------------------------------------------------------- -- | The strategy for producing QuasiQuoters which -- this datatype aims to facilitate is as follows. -- Given a collection of datatypes which make up -- the to-be-quasiquoted languages AST, make each -- type in this collection an instance of at least -- @Show@ and @Lift@. Now, assuming @parsePat@ and -- @parseExp@, both of type @String -> Q a@ (where @a@ -- is the top level type of the AST), are the pair of -- functions you wish to use for parsing in pattern and -- expression context respectively, put them inside -- a @Quoter@ datatype and pass this to quasify. {- data Quoter a = Quoter { expQ :: (Lift a) => String -> Q a , patQ :: (Show a) => String -> Q a } quasify :: (Show a, Lift a) => Quoter a -> QuasiQuoter quasify q = QuasiQuoter (toExpQ (expQ q)) (toPatQ (patQ q)) -} toExpQ :: (Lift a) => (String -> Q a) -> (String -> ExpQ) toExpQ parseQ = (lift =<<) . parseQ toPatQ :: (Show a) => (String -> Q a) -> (String -> PatQ) toPatQ parseQ = (showToPatQ =<<) . parseQ showToPatQ :: (Show a) => a -> PatQ showToPatQ = either fail return . parsePat . show ----------------------------------------------------------------------------- eitherQ :: (e -> String) -> Either e a -> Q a eitherQ toStr = either (fail . toStr) return ----------------------------------------------------------------------------- normalizeT :: (Data a) => a -> a normalizeT = everywhere (mkT go) where go :: Type -> Type go (ConT n) | n == ''[] = ListT go (AppT (TupleT 1) t) = t go (ConT n) | Just m <- findIndex (== n) tupleNames = TupleT (m + 2) where tupleNames = map tupleTypeName [2 .. 64] go t = t ----------------------------------------------------------------------------- haskell-src-meta-0.8.12/tests/0000755000000000000000000000000007346545000014271 5ustar0000000000000000haskell-src-meta-0.8.12/tests/Main.hs0000644000000000000000000000606707346545000015522 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import qualified Control.Monad.Fail as Fail import Data.Data (Data, cast, gfoldl) import Data.Functor.Const (Const (Const, getConst)) import qualified Language.Haskell.Exts as Exts import qualified Language.Haskell.Exts.Extension as Extension import qualified Language.Haskell.Exts.Parser as Parser import Language.Haskell.Meta.Parse import Language.Haskell.Meta.Syntax.Translate import qualified Language.Haskell.TH as TH import Test.HUnit (Assertion, (@?=)) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (testCase) type Test = TestTree main :: IO () main = defaultMain (testGroup "unit" tests) tests :: [Test] tests = [ derivingClausesTest , typeAppTest , orderInTypeTuples ] derivingClausesTest :: Test derivingClausesTest = testCase "Deriving clauses preserved" $ roundTripDecls "data Foo = Foo deriving (A, B, C)" orderInTypeTuples :: Test orderInTypeTuples = testCase "Ensure that type tuples reconstructed in proper order" $ do expected @?= actual where expected :: [TH.TyLit] expected = collectAll (toExp parsed) actual = [TH.StrTyLit "a", TH.StrTyLit "b"] parsed :: Exts.Exp Exts.SrcSpanInfo parsed = case Exts.parseExpWithMode mode "foo @'(\"a\", \"b\")" of Exts.ParseOk v -> v e -> error $ show e mode :: Exts.ParseMode mode = Exts.defaultParseMode { Exts.extensions = [ Exts.EnableExtension Exts.TypeApplications , Exts.EnableExtension Exts.DataKinds ] } collectAll :: (Data a, Data b) => a -> [b] collectAll = ($ []) . go where go :: forall a b. (Data a, Data b) => a -> [b] -> [b] go = \x -> case cast x of Just x' -> (x' :) Nothing -> getConst $ gfoldl ap (const $ Const id) x where ap :: Data x => Const ([b] -> [b]) (x -> y) -> x -> Const ([b] -> [b]) y ap (Const acc) x = Const $ acc . go x typeAppMode :: Exts.ParseMode typeAppMode = Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.TypeApplications] } typeAppTest :: Test typeAppTest = testCase "Type app preserved" $ roundTripDeclsWithMode typeAppMode "tenStr = show @Int 10" roundTripDecls :: String -> Assertion roundTripDecls s = do declsExts <- liftEither $ parseHsDecls s declsExts' <- liftEither $ parseDecs s >>= parseHsDecls . TH.pprint declsExts' @?= declsExts roundTripDeclsWithMode :: Exts.ParseMode -> String -> Assertion roundTripDeclsWithMode mode s = do declsExts <- liftEither $ parseHsDeclsWithMode mode s declsExts' <- liftEither $ parseDecsWithMode mode s >>= parseHsDeclsWithMode mode . TH.pprint declsExts' @?= declsExts liftEither :: Fail.MonadFail m => Either String a -> m a liftEither = either fail return haskell-src-meta-0.8.12/tests/Splices.hs0000644000000000000000000000503307346545000016230 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 904 {-# LANGUAGE TypeOperators #-} #endif {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} #if MIN_VERSION_template_haskell(2,14,0) {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE QuantifiedConstraints #-} #endif -- | Tests stuff mostly by just compiling correctly import qualified Language.Haskell.Exts.Extension as Extension import qualified Language.Haskell.Exts.Parser as Parser import qualified Language.Haskell.Meta as Meta ----- Testing names ----- -- Test that the unit constructor works $(either error return $ Meta.parseDecs "unit :: IO ()\nunit = return ()") -- Testing that the [] constructor works in types, $(either error return $ Meta.parseDecs "nilp :: [a] -> ([] a)\nnilp [] = []") $(either error return $ Meta.parseDecs "pair :: (,) Int Int\npair = (,) 1 2") ----- Testing classes and instances ----- $(either error return $ Meta.parseDecs $ unlines ["class MyClass a where mymethod :: a -> b -> (a,b)" ,"instance MyClass Bool where mymethod a b = (a,b)" ]) $(either error return $ Meta.parseDecsWithMode (Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.TypeApplications] }) $ unlines ["tenStr :: String" ,"tenStr = show @Int 10"]) #if MIN_VERSION_template_haskell(2,14,0) $(either error return $ Meta.parseDecsWithMode (Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.QuantifiedConstraints, Extension.EnableExtension Extension.ExplicitForAll] }) $ unlines ["class (forall a. Eq a => Eq (f a)) => Eq1 f where" ," eq1 :: f Int -> f Int -> Bool" ," eq1 = (==)" ,"" ,"instance Eq1 []"]) #else $(either error return $ Meta.parseDecs $ unlines ["eq1 :: [Int] -> [Int] -> Bool" ,"eq1 = (==)"]) #endif $(either error return $ Meta.parseDecsWithMode (Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.GADTs] }) $ unlines [ -- Not sure why but ghc 7.10 complains that "type var a is not in scope" "intConstraint :: (a ~ Int) => a" ,"intConstraint = 3"]) -- Just to check that it works as intended main :: IO () main = do -9 <- return $(either error return $ Meta.parseExp "-3^2 :: Int") :: IO Int () <- unit [] <- return (nilp []) (1,2) <- return pair (True,1) <- return $ mymethod True 1 "10" <- return tenStr 3 <- return intConstraint True <- return $ eq1 [1] [1] return () haskell-src-meta-0.8.12/tests/TestExamples.hs0000644000000000000000000000223107346545000017241 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} import qualified BF import qualified Hs import qualified HsHere import qualified SKI import SKI (SKI (I, K, S, (:$))) -- Very dumb test framework shouldBe :: (Show a, Eq a) => a -> a -> IO () actual `shouldBe` expected = case actual == expected of True -> return () False -> do putStr "Expected: " print expected putStr "Actual: " print actual fail "Expectation failure" a :: Int -> String a x = [HsHere.here| random "text" $(x + 1) something else|] hereTest :: IO () hereTest = do a 3 `shouldBe` (" random \"text\" "++ show (3 + 1 :: Int) ++"\n something else") -- TODO: better test exercising the bf quasiquoter bfTest :: IO () bfTest = do BF.eval_ (BF.parse BF.bfHelloWorld) "" `shouldBe` "Hello World!\n" hsTest :: IO () hsTest = do (\ [Hs.hs|b@(x,_)|] -> [Hs.hs|(b,x)|]) (42 :: Int,88 :: Int) `shouldBe` ((42,88),42) -- TODO: better test exercising the ski quasiquoter skiTest :: IO () skiTest = do SKI.parse "S(SS)IK(SK)" `shouldBe` ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"") main :: IO () main = do putStrLn "" hereTest bfTest hsTest skiTest