haskell-src-meta 0.5.1.2 → 0.8.16
raw patch · 19 files changed
Files
- ChangeLog +193/−0
- README +0/−74
- README.md +16/−0
- examples/BF.hs +55/−23
- examples/Hs.hs +17/−3
- examples/HsHere.hs +56/−24
- examples/SKI.hs +56/−26
- haskell-src-meta.cabal +66/−31
- src/Language/Haskell/Meta.hs +3/−2
- src/Language/Haskell/Meta/Extensions.hs +407/−0
- src/Language/Haskell/Meta/Parse.hs +52/−60
- src/Language/Haskell/Meta/Parse/Careful.hs +0/−73
- src/Language/Haskell/Meta/Syntax/Translate.hs +828/−676
- src/Language/Haskell/Meta/THCompat.hs +30/−0
- src/Language/Haskell/Meta/Utils.hs +120/−244
- src/Language/Haskell/TH/Instances/Lift.hs +0/−89
- tests/Main.hs +89/−0
- tests/Splices.hs +78/−0
- tests/TestExamples.hs +53/−0
+ ChangeLog view
@@ -0,0 +1,193 @@+0.8.15+- Support for GHC 9.12 (by alexfmpe)++0.8.14+- Support for GHC 9.10 (by Troels Henriksen)++0.8.13+- Support for GHC 9.8 (by Vladislav Zavialov)++0.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
− README
@@ -1,74 +0,0 @@-haskell-src-meta is a package originally by Matt Morrow for converting a-parsed AST from haskell-src-exts to a TH AST for use in splices and-quasiquoters. The last version Matt released before he disappeared from-the Haskell community was 0.0.6, but by that time his library was-already popular, so some community members eventually decided to take-over maintenance of the package, keeping it up to date with the latest-versions of TH etc.--I don't really view this as "my" package so if you want write access to-the github repository, or you think you could do a better job as-maintainer, just ask.--Major changes:--0.5.1.1 -> 0.5.1.2:-- More sensible determination of TH version available--0.5.1 -> 0.5.1.1:-- View pattern support, thanks to Nicolas Frisby.--0.5.0.3 -> 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.2 -> 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.1 -> 0.5.0.2:-- Fixed bug in translation of tuple constructors--0.5 -> 0.5.0.1:-- Added support for primitive string literals (Only in TH >= 2.5)--0.4.0.2 -> 0.5:-- Added support for instance declarations--0.4.0.1 -> 0.4.0.2:-- Compatibility with GHC 7.2--0.4 -> 0.4.0.1:-- Deprecate myDefaultParseMode and myDefaultExtensions in L.H.M.Parse--0.3 -> 0.4:-- Remove Language.Haskell.Meta.Syntax.Vars and the L.H.M.Syntax re-export module-- Remove dependency on containers-- Add support for let statements in (pattern) guards-- Add support for negative patterns-- Remove "support" for SpliceExps that didn't really make sense-- Improve many error messages where things are unimplemented or impossible--0.2 -> 0.3:-- Fixes/additions to inline pragma support (Jonas Duregard)-- Compatibility with GHC 7 and TH 2.5 - totalling three major versions!-- Move some of the quasiquoters to their own package, and stop exporting- the rest (they are kept as examples of usage)--0.1.1 -> 0.2:-- Compatibility with GHC 6.10 and TH 2.3 (Geoffrey Mainland)-- Add support for do-blocks, pattern guards (Adam Vogt)-- Add applicative-do quasiquoter (Adam Vogt)--0.1.0 -> 0.1.1:-- Add support for inline pragmas, and improve support for type- signatures (patch by Jonas Duregard)--0.0.6 -> 0.1.0:-- Used the th-lift library to autogenerate the instances of Lift in- Language.Haskell.TH.Instances.Lift-- Added support for the new features of template-haskell-2.4.0.0:- contexts, kinds, bang patterns, unboxed word literals.-- Updated use of haskell-src-exts in response to API changes.-- Added ToDecs class because some HSE Decls don't map to a single Dec.- (patch by Jonas Duregard)
+ README.md view
@@ -0,0 +1,16 @@+The `haskell-src-meta` Package [](https://hackage.haskell.org/package/haskell-src-meta) [](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.
examples/BF.hs view
@@ -1,24 +1,47 @@-{-# LANGUAGE BangPatterns, TemplateHaskell #-}+-- TODO: knock out these warnings+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} -module Language.Haskell.Meta.QQ.BF (- bf,bf2,bfHelloWorld+module BF (+ bf,bf2,bfHelloWorld,eval_,parse, exec, test0 ) where -import Language.Haskell.Meta (parsePat)+import Language.Haskell.Meta (parsePat) import Language.Haskell.TH.Lib import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax -import Data.Char-import Data.IntMap(IntMap)-import qualified Data.IntMap as IM+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 }+bf = QuasiQuoter+ { quoteExp = bfExpQ+ , quotePat = bfPatQ+ , quoteType = quoteTypeNotImplemented+ , quoteDec = quoteDecNotImplemented+ } bf2 :: QuasiQuoter-bf2 = QuasiQuoter { quoteExp = bf2ExpQ, quotePat = bfPatQ }+bf2 = QuasiQuoter+ { quoteExp = bf2ExpQ+ , quotePat = bfPatQ+ , quoteType = quoteTypeNotImplemented+ , quoteDec = quoteDecNotImplemented+ } bf2ExpQ :: String -> ExpQ bf2ExpQ s = [|eval (parse s)|]@@ -32,18 +55,33 @@ . show . parse) s case p of- Left e -> fail e+ 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 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) @@ -133,7 +171,7 @@ go !n acc (c :cs) k = go n acc cs k -+test0 :: IO [Bf] test0 = do a <- readFile "prime.bf" return (parse a)@@ -174,9 +212,3 @@ go !n acc (c :cs) = (n+1, [Error ("go error: char "++show n ++" illegal character: "++show c)], []) -}------
examples/Hs.hs view
@@ -2,14 +2,24 @@ -- | Eat your face! -module Language.Haskell.Meta.QQ.Hs (hs, pat) where+module Hs (hs, pat) where -import Language.Haskell.Meta (parseExp, parsePat)+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)@@ -19,6 +29,8 @@ hs = QuasiQuoter { quoteExp = either fail transformE . parseExp , quotePat = either fail transformP . parsePat+ , quoteType = quoteTypeNotImplemented+ , quoteDec = quoteDecNotImplemented } transformE :: Exp -> ExpQ@@ -32,5 +44,7 @@ { quoteExp = quoteExp hs , quotePat = \s -> case parseExp s of Left err -> fail err- Right e -> either fail return (parsePat . pretty $ e)+ Right e -> either fail return (parsePat . pretty $ e)+ , quoteType = quoteTypeNotImplemented+ , quoteDec = quoteDecNotImplemented }
examples/HsHere.hs view
@@ -1,26 +1,51 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-}+-- TODO: knock out these warnings+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-} -module Language.Haskell.Meta.QQ.HsHere (here) where+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-} -import Language.Haskell.Meta (parseExp, parsePat)-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Language.Haskell.Meta.Utils (cleanNames)-import Text.ParserCombinators.ReadP-import Data.Typeable(Typeable)-import Data.Generics(Data)+module HsHere+ ( here+ , lexemeP+ , nestedP+ , parensP+ , bracksP+ , oparenP+ , obrackP+ , cbrackP+ ) where +import qualified Control.Monad.Fail as Fail+import Data.Generics (Data)+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)+ deriving (Eq,Show,Data) -- | Example: ----- > a x = [$here| random "text" $(x + 1)+-- > a x = [here| random "text" $(x + 1) -- > something else|] -- -- Is like:@@ -28,21 +53,26 @@ -- > a x = " random \"text\" "++ show (x + 1) ++"\n something else" here :: QuasiQuoter here = QuasiQuoter- {quoteExp = hereExpQ+ {quoteType = quoteTypeNotImplemented+ ,quoteDec = quoteDecNotImplemented+ ,quoteExp = hereExpQ ,quotePat = herePatQ} -instance Lift Here- where lift = liftHere+instance Lift Here where+ lift (TextH s) = (litE . stringL) s+ lift (CodeH e) = [|show $(return e)|]+ lift (ManyH hs) = [|concat $(listE (fmap lift hs))|] -liftHere :: Here -> ExpQ-liftHere (TextH s) = (litE . stringL) s-liftHere (CodeH e) = [|show $(return e)|]-liftHere (ManyH hs) = [|concat $(listE (fmap liftHere 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"+ [] -> fail "here: parse error" e:_ -> lift (cleanNames e) herePatQ :: String -> PatQ@@ -52,7 +82,7 @@ . pprint . cleanNames) e case p of- Left e -> fail e+ Left e -> fail e Right p -> return p run :: String -> [Here]@@ -81,7 +111,8 @@ | c:s <- s = do skip 1 (TextH . (c:)) `fmap` munch (not.(`elem`"\\$"))- where go _ acc [] = return (TextH (reverse acc))+ 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@@ -105,10 +136,11 @@ 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 ']'-
examples/SKI.hs view
@@ -1,20 +1,45 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-}+-- 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 #-} -module Language.Haskell.Meta.QQ.SKI (SKI(..),ski) where+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-} -import Language.Haskell.Meta (parseExp, parsePat)-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unQ)-import Text.ParserCombinators.ReadP-import Data.Typeable(Typeable)-import Data.Generics(Data)-import Text.PrettyPrint(render)+module SKI+ ( SKI(..)+ , ski+ , parse+ , bracksP+ , obrackP+ , cbrackP+ ) where +import qualified Control.Monad.Fail as Fail+import Data.Generics (Data)+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)+ deriving (Eq,Data) run :: String -> [SKI] run = fmap eval . fst . parse@@ -26,29 +51,37 @@ eval (I :$ x) = eval x eval ((K :$ x) :$ y) = eval x eval (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))-eval (E e :$ E e') = E (unQ[|$(return e) $(return e')|])+eval (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 (unQ[|$(return e) $(return e')|])+eval0 (E e :$ E e') = E (unsafeRunQ[|$(return e) $(return e')|]) eval0 x = x ski :: QuasiQuoter ski = QuasiQuoter- {quoteExp = skiExpQ- ,quotePat = skiPatQ}+ { 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|]+ 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@@ -64,7 +97,7 @@ skiExpQ :: String -> ExpQ skiExpQ s = case run s of- [] -> fail "ski: parse error"+ [] -> fail "ski: parse error" e:_ -> lift (cleanNames e) skiPatQ :: String -> PatQ@@ -74,7 +107,7 @@ . pprint . cleanNames) e case p of- Left e -> fail e+ Left e -> fail e Right p -> return p -- ghci> parse "S(SS)IK(SK)"@@ -150,6 +183,3 @@ c = s $ (b $ b $ s) $ k $ k b = s $ (k $ s) $ k -}---
haskell-src-meta.cabal view
@@ -1,53 +1,88 @@ name: haskell-src-meta-version: 0.5.1.2-cabal-version: >= 1.6+version: 0.8.16+cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: LICENSE-category: Language+category: Language, Template Haskell author: Matt Morrow copyright: (c) Matt Morrow-maintainer: Ben Millwood <haskell@benmachine.co.uk>-bug-reports: https://github.com/benmachine/haskell-src-meta/issues-stability: experimental-tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.1+maintainer: athas@sigkill.dk+bug-reports: https://github.com/haskell-party/haskell-src-meta/issues+tested-with: GHC == 9.14.1 synopsis: Parse source to template-haskell abstract syntax. description: The translation from haskell-src-exts abstract syntax to template-haskell abstract syntax isn't 100% complete yet. -extra-source-files: examples/*.hs README+extra-source-files: ChangeLog README.md library- build-depends: base >= 4.2 && < 4.6,- haskell-src-exts >= 1.8 && < 1.14,+ default-language: Haskell2010+ build-depends: base >= 4.10 && < 5,+ haskell-src-exts >= 1.21 && < 1.25, pretty >= 1.0 && < 1.2,- syb >= 0.1 && < 0.4,- th-lift == 0.5.*-- if impl(ghc >= 7.4)- Build-depends: template-haskell >= 2.7 && < 2.9- else- Build-depends: template-haskell >= 2.4 && < 2.7,- uniplate >= 1.3 && < 1.7+ syb >= 0.1 && < 0.8,+ template-haskell >= 2.12 && < 2.25,+ th-orphans >= 0.12 && < 0.14 - extensions: CPP,- RankNTypes,- StandaloneDeriving,- TemplateHaskell,- TypeSynonymInstances,- FlexibleContexts,- FlexibleInstances,- DeriveDataTypeable,- PatternGuards hs-source-dirs: src exposed-modules: Language.Haskell.Meta+ Language.Haskell.Meta.Extensions Language.Haskell.Meta.Parse- Language.Haskell.Meta.Parse.Careful Language.Haskell.Meta.Syntax.Translate- Language.Haskell.TH.Instances.Lift 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/benmachine/haskell-src-meta.git-+ location: https://github.com/haskell-party/haskell-src-meta.git
src/Language/Haskell/Meta.hs view
@@ -1,4 +1,3 @@- {- | Module : Language.Haskell.Meta Copyright : (c) Matt Morrow 2008@@ -9,10 +8,12 @@ -} 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.Lift()+import Language.Haskell.TH.Instances ()
+ src/Language/Haskell/Meta/Extensions.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE CPP #-}+{- |+ Module : Language.Haskell.Meta.Parse+ Copyright : (c) Serokell 2022, Adam Bergmark 2022+ License : BSD3+ Maintainer : Adam Bergmark <adam@bergmark.nl>+ 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++#if MIN_VERSION_haskell_src_exts(1,24,0)+ Exts.ImportQualifiedPost ->+#if MIN_VERSION_template_haskell(2,16,0)+ Just TH.ImportQualifiedPost+#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.CUSKs -> Nothing+ TH.StandaloneKindSignatures -> Nothing+ TH.ImportQualifiedPost ->+#if MIN_VERSION_haskell_src_exts(1,24,0)+ Just Exts.ImportQualifiedPost+#else+ Nothing+#endif+#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++-- 2.21.0 ---------------------------------------++#if MIN_VERSION_template_haskell(2,21,0)+ TH.TypeAbstractions -> Nothing+ TH.ExtendedLiterals -> Nothing+#endif++-- 2.22.0 ---------------------------------------++#if MIN_VERSION_template_haskell(2,22,0)+ TH.RequiredTypeArguments -> Nothing+ TH.ListTuplePuns -> Nothing+#endif++-- 2.23.0 ---------------------------------------++#if MIN_VERSION_template_haskell(2,23,0)+ TH.MultilineStrings -> Nothing+ TH.NamedDefaults -> Nothing+ TH.OrPatterns -> Nothing+#endif++#if MIN_VERSION_template_haskell(2,24,0)+ TH.ExplicitLevelImports -> Nothing+ TH.ImplicitStagePersistence -> Nothing+#endif++ -- NB: when adding a case here, you may also need to update `toExtension`+++-----------------------------------------------------------------------------
src/Language/Haskell/Meta/Parse.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {- | Module : Language.Haskell.Meta.Parse Copyright : (c) Matt Morrow 2008@@ -12,81 +13,64 @@ parseExp, parseType, parseDecs,+ parseDecsWithMode, myDefaultParseMode, myDefaultExtensions, parseResultToEither, parseHsModule, parseHsDecls,+ parseHsDeclsWithMode, parseHsType, parseHsExp, parseHsPat, pprHsModule, moduleDecls,- emptySrcLoc,+ noSrcSpanInfo, emptyHsModule ) where -import Language.Haskell.TH.Syntax-import Language.Haskell.Meta.Syntax.Translate-import qualified Language.Haskell.Exts.Syntax as Hs-import Language.Haskell.Exts.Annotated.Fixity as Fix-import Language.Haskell.Exts.Extension-import Language.Haskell.Exts.Parser hiding (parseExp, parseType, parsePat)-import Language.Haskell.Exts.Pretty+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+parsePat = fmap toPat . parseHsPat parseExp :: String -> Either String Exp-parseExp = either Left (Right . toExp) . parseHsExp+parseExp = fmap toExp . parseHsExp parseType :: String -> Either String Type-parseType = either Left (Right . toType) . parseHsType+parseType = fmap toType . parseHsType parseDecs :: String -> Either String [Dec]-parseDecs = either Left (Right . toDecs) . parseHsDecls+parseDecs = fmap toDecs . parseHsDecls +-- | @since 0.8.2+parseDecsWithMode :: ParseMode -> String -> Either String [Dec]+parseDecsWithMode parseMode = fmap toDecs+ . parseHsDeclsWithMode parseMode+ ----------------------------------------------------------------------------- {-# DEPRECATED myDefaultParseMode, myDefaultExtensions "The provided ParseModes aren't very meaningful, use your own instead" #-} myDefaultParseMode :: ParseMode-myDefaultParseMode = ParseMode+myDefaultParseMode = defaultParseMode {parseFilename = []- ,extensions = myDefaultExtensions- ,ignoreLinePragmas = False- ,ignoreLanguagePragmas = False- ,fixities = defaultFixities}---- This is a silly hack to make things work on haskell-src-exts versions--- 1.10 and 1.11 simultaneously. I justify it because myDefaultParseMode is--- deprecated anyway.------ Essentially we want defaultFixities to be baseFixities or Just baseFixities--- as appropriate. We do this without requiring FlexibleInstances using the--- same trick as Show on lists does.-class DefaultFixities a where- defaultFixities :: a- defaultFixities =- error "Language.Haskell.Meta.Parse.defaultFixities undefined"- defaultFixityList :: [a]- defaultFixityList =- error "Language.Haskell.Meta.Parse.defaultFixityList undefined"--instance DefaultFixities Fix.Fixity where- defaultFixityList = baseFixities--instance DefaultFixities a => DefaultFixities [a] where- defaultFixities = defaultFixityList--instance DefaultFixities a => DefaultFixities (Maybe a) where- defaultFixities = Just defaultFixities+ ,baseLanguage = Haskell2010+ ,extensions = map EnableExtension myDefaultExtensions+ } -myDefaultExtensions :: [Extension]+myDefaultExtensions :: [KnownExtension] myDefaultExtensions = [PostfixOperators ,QuasiQuotes ,UnicodeSyntax@@ -96,7 +80,8 @@ ,TemplateHaskell ,RankNTypes ,MultiParamTypeClasses- ,RecursiveDo]+ ,RecursiveDo+ ,TypeApplications] parseResultToEither :: ParseResult a -> Either String a parseResultToEither (ParseOk a) = Right a@@ -104,47 +89,54 @@ = let line = Hs.srcLine loc - 1 in Left (unlines [show line,show loc,e]) -parseHsModule :: String -> Either String Hs.Module+parseHsModule :: String -> Either String (Hs.Module Hs.SrcSpanInfo) parseHsModule = parseResultToEither . parseModuleWithMode myDefaultParseMode -parseHsDecls :: String -> Either String [Hs.Decl]-parseHsDecls = either Left (Right . moduleDecls)+parseHsDecls :: String -> Either String [Hs.Decl Hs.SrcSpanInfo]+parseHsDecls = fmap moduleDecls . parseResultToEither . parseModuleWithMode myDefaultParseMode +-- | @since 0.8.2+parseHsDeclsWithMode :: ParseMode -> String -> Either String [Hs.Decl Hs.SrcSpanInfo]+parseHsDeclsWithMode parseMode = fmap moduleDecls+ . parseResultToEither . parseModuleWithMode parseMode -parseHsType :: String -> Either String Hs.Type++parseHsType :: String -> Either String (Hs.Type Hs.SrcSpanInfo) parseHsType = parseResultToEither . parseTypeWithMode myDefaultParseMode -parseHsExp :: String -> Either String Hs.Exp+parseHsExp :: String -> Either String (Hs.Exp Hs.SrcSpanInfo) parseHsExp = parseResultToEither . parseExpWithMode myDefaultParseMode -parseHsPat :: String -> Either String Hs.Pat+parseHsPat :: String -> Either String (Hs.Pat Hs.SrcSpanInfo) parseHsPat = parseResultToEither . parsePatWithMode myDefaultParseMode -pprHsModule :: Hs.Module -> String+pprHsModule :: Hs.Module Hs.SrcSpanInfo -> String pprHsModule = prettyPrint -moduleDecls :: Hs.Module -> [Hs.Decl]-moduleDecls (Hs.Module _ _ _ _ _ _ x) = x+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 [] [] -emptySrcLoc :: Hs.SrcLoc-emptySrcLoc = (Hs.SrcLoc [] 0 0)--emptyHsModule :: String -> Hs.Module+emptyHsModule :: String -> Hs.Module Hs.SrcSpanInfo emptyHsModule n = (Hs.Module- emptySrcLoc- (Hs.ModuleName n)+ noSrcSpanInfo+ (Just (Hs.ModuleHead noSrcSpanInfo (Hs.ModuleName noSrcSpanInfo n) Nothing Nothing)) []- Nothing- Nothing [] [])++noSrcSpanInfo :: Hs.SrcSpanInfo+noSrcSpanInfo = Hs.noInfoSpan (Hs.mkSrcSpan Hs.noLoc Hs.noLoc) {- ghci> :i Module
− src/Language/Haskell/Meta/Parse/Careful.hs
@@ -1,73 +0,0 @@-{- |-This module provides the tools to handle operator fixities in infix expressions correctly.--The problem we solve is the following. Consider making a quasiquoter which antiquotes to Haskell - for instance, the quasiquoter in <http://hackage.haskell.org/package/hmatrix-static> allows me to write--> myVec :: Vector Double-> myVec = [vec| 2+3*4, 5-4-3 |]--To correctly parse such expressions, we need to know the fixities and precedences of the operators, so that the above is parsed the same way as--> myVec = [vec| 2+(3*4), (5-4)-3 |]--There is a danger, if we are not careful in parsing, that the above expression instead parses as--> myVec = [vec| (2+3)*4, 5-(4-3) |]--which is a surprising bug, and would only be detected through testing at runtime, rather than at compile time.--When this danger arises, we use this \"careful\" module. It handles \"unresolved infix\" expressions such as @2+3*4@ in two ways, depending on the version of GHC:-- * in GHC 7.4 and above (where support for \"unresolved infix\" was added in Template Haskell), resolution of the infix expression is deferred to the compiler, which has all fixities available to it.-- * prior to GHC 7.4, any ambiguous infix expression is flagged as a parse error at compile time, and the user is advised to resolve the ambiguity by adding parentheses.---}-module Language.Haskell.Meta.Parse.Careful(- parsePat, - parseExp, - parseType, - parseDecs- ) where--import qualified Language.Haskell.Meta.Parse as Sloppy-import qualified Language.Haskell.Meta.Syntax.Translate as Translate-import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.Exts.Syntax as Hs-#if !(MIN_VERSION_template_haskell(2,7,0))-import Data.Generics.Uniplate.Data-#endif--doChecked parser translater p = - case parser p of - Left s -> Left s- Right p' | amb p' -> Left "Infix expression could not be resolved as operator fixities are not known. Resolve ambiguity by adding parentheses"- | otherwise -> Right (translater p')--parsePat :: String -> Either String TH.Pat-parsePat = doChecked Sloppy.parseHsPat Translate.toPat--parseExp :: String -> Either String TH.Exp-parseExp = doChecked Sloppy.parseHsExp Translate.toExp--parseType :: String -> Either String TH.Type-parseType = doChecked Sloppy.parseHsType Translate.toType--parseDecs :: String -> Either String [TH.Dec]-parseDecs = doChecked Sloppy.parseHsDecls Translate.toDecs--#if MIN_VERSION_template_haskell(2,7,0)-amb = const False-#else-amb syn = any isAmbExp (universeBi syn) || any isAmbPat (universeBi syn)- where- isAmbExp (Hs.InfixApp Hs.InfixApp{} _ _) = True- isAmbExp (Hs.InfixApp _ _ Hs.InfixApp{}) = True- isAmbExp (Hs.InfixApp Hs.RightSection{} _ _) = True- isAmbExp (Hs.InfixApp _ _ Hs.LeftSection{}) = True- isAmbExp _ = False- - isAmbPat (Hs.PInfixApp Hs.PInfixApp{} _ _) = True- isAmbPat (Hs.PInfixApp _ _ Hs.PInfixApp{}) = True- isAmbPat _ = False-#endif
src/Language/Haskell/Meta/Syntax/Translate.hs view
@@ -1,676 +1,828 @@-{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}--{- |- Module : Language.Haskell.Meta.Syntax.Translate- Copyright : (c) Matt Morrow 2008- License : BSD3- Maintainer : Matt Morrow <mjm2002@gmail.com>- Stability : experimental- Portability : portable (template-haskell)--}--module Language.Haskell.Meta.Syntax.Translate (- module Language.Haskell.Meta.Syntax.Translate-) where--import Data.Typeable-import Data.List (foldl', nub, (\\))-import Language.Haskell.TH.Syntax-import qualified Language.Haskell.Exts.Syntax as Hs----------------------------------------------------------------------------------class ToName a where toName :: a -> Name-class ToLit a where toLit :: a -> Lit-class ToType a where toType :: a -> Type-class ToPat a where toPat :: a -> Pat-class ToExp a where toExp :: a -> Exp-class ToDecs a where toDecs :: a -> [Dec]-class ToDec a where toDec :: a -> Dec-class ToStmt a where toStmt :: a -> Stmt-class ToLoc a where toLoc :: a -> Loc---- for error messages-moduleName = "Language.Haskell.Meta.Syntax.Translate"---- When to use each of these isn't always clear: prefer 'todo' if unsure.-noTH :: Show e => String -> e -> a-noTH fun thing = error . concat $ [moduleName, ".", fun,- ": no TH representation for: ", show thing]--todo :: Show e => String -> e -> a-todo fun thing = error . concat $ [moduleName, ".", fun,- ": not implemented: ", show thing]--nonsense :: Show e => String -> String -> e -> a-nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun,- ": nonsensical: ", inparticular, ": ", show thing]----------------------------------------------------------------------------------instance ToExp Lit where- toExp = LitE-instance (ToExp a) => ToExp [a] where- toExp = ListE . fmap toExp-instance (ToExp a, ToExp b) => ToExp (a,b) where- toExp (a,b) = TupE [toExp a, toExp b]-instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where- toExp (a,b,c) = TupE [toExp a, toExp b, toExp c]-instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where- toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d]---instance ToPat Lit where- toPat = LitP-instance (ToPat a) => ToPat [a] where- toPat = ListP . fmap toPat-instance (ToPat a, ToPat b) => ToPat (a,b) where- toPat (a,b) = TupP [toPat a, toPat b]-instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where- toPat (a,b,c) = TupP [toPat a, toPat b, toPat c]-instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where- toPat (a,b,c,d) = TupP [toPat a, toPat b, toPat c, toPat d]---instance ToLit Char where- toLit = CharL-instance ToLit String where- toLit = StringL-instance ToLit Integer where- toLit = IntegerL-instance ToLit Int where- toLit = IntegerL . toInteger-instance ToLit Float where- toLit = RationalL . toRational-instance ToLit Double where- toLit = RationalL . toRational------------------------------------------------------------------------------------- * ToName {String,HsName,Module,HsSpecialCon,HsQName}---instance ToName String where- toName = mkName--instance ToName Hs.Name where- toName (Hs.Ident s) = toName s- toName (Hs.Symbol s) = toName s--instance ToName Hs.Module where- toName (Hs.Module _ (Hs.ModuleName s) _ _ _ _ _) = toName s---instance ToName Hs.SpecialCon where- toName Hs.UnitCon = '()- toName Hs.ListCon = '[]- toName Hs.FunCon = ''(->)- toName (Hs.TupleCon _ n)- | n<2 = '()- | otherwise =- let x = maybe [] (++".") (nameModule '(,))- in mkName . concat $ x : ["(",replicate (n-1) ',',")"]- toName Hs.Cons = '(:)---instance ToName Hs.QName where--- toName (Hs.Qual (Hs.Module []) n) = toName n- toName (Hs.Qual (Hs.ModuleName []) n) = toName n- toName (Hs.Qual (Hs.ModuleName m) n) =- let m' = show . toName $ m- n' = show . toName $ n- in toName . concat $ [m',".",n']- toName (Hs.UnQual n) = toName n- toName (Hs.Special s) = toName s------------------------------------------------------------------------------------- * ToLit HsLiteral---instance ToLit Hs.Literal where- toLit (Hs.Char a) = CharL a- toLit (Hs.String a) = StringL a- toLit (Hs.Int a) = IntegerL a- toLit (Hs.Frac a) = RationalL a- toLit (Hs.PrimChar a) = CharL a -- XXX-#if MIN_VERSION_template_haskell(2,5,0)- toLit (Hs.PrimString a) = StringPrimL a-#else /* MIN_VERSION_template_haskell(2,5,0) */- toLit (Hs.PrimString a) = StringL a -- XXX-#endif /* MIN_VERSION_template_haskell(2,5,0) */- toLit (Hs.PrimInt a) = IntPrimL a- toLit (Hs.PrimFloat a) = FloatPrimL a- toLit (Hs.PrimDouble a) = DoublePrimL a-#if MIN_VERSION_template_haskell(2,4,0)- toLit (Hs.PrimWord a) = WordPrimL a-#endif /* MIN_VERSION_template_haskell(2,4,0) */------------------------------------------------------------------------------------ * ToPat HsPat---instance ToPat Hs.Pat where- toPat (Hs.PVar n)- = VarP (toName n)- toPat (Hs.PLit l)- = LitP (toLit l)-{--ghci> parseHsPat "-2"-Right (HsPParen (HsPNeg (HsPLit (HsInt 2))))--}- toPat (Hs.PNeg (Hs.PLit l)) = LitP $ case toLit l of- IntegerL z -> IntegerL (negate z)- RationalL q -> RationalL (negate q)- IntPrimL z' -> IntPrimL (negate z')- FloatPrimL r' -> FloatPrimL (negate r')- DoublePrimL r'' -> DoublePrimL (negate r'')- _ -> nonsense "toPat" "negating wrong kind of literal" l- toPat (Hs.PNeg p) = nonsense "toPat" "negating non-literal" p-#if MIN_VERSION_template_haskell(2,7,0)- toPat (Hs.PInfixApp p n q) = UInfixP (toPat p) (toName n) (toPat q) -#else- toPat (Hs.PInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q)-#endif- toPat (Hs.PApp n ps) = ConP (toName n) (fmap toPat ps)- toPat (Hs.PTuple ps) = TupP (fmap toPat ps)- toPat (Hs.PList ps) = ListP (fmap toPat ps)-#if MIN_VERSION_template_haskell(2,7,0) - toPat (Hs.PParen p) = ParensP (toPat p) -#else- toPat (Hs.PParen p) = toPat p-#endif- toPat (Hs.PRec n pfs) = let toFieldPat (Hs.PFieldPat n p) = (toName n, toPat p)- in RecP (toName n) (fmap toFieldPat pfs)- toPat (Hs.PAsPat n p) = AsP (toName n) (toPat p)- toPat (Hs.PWildCard) = WildP- toPat (Hs.PIrrPat p) = TildeP (toPat p)- toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t)-#if MIN_VERSION_template_haskell(2,5,0)- toPat (Hs.PViewPat e p) = ViewP (toExp e) (toPat p)-#endif- -- regular pattern- toPat p@Hs.PRPat{} = noTH "toPat" p- -- XML stuff- toPat p@Hs.PXTag{} = noTH "toPat" p- toPat p@Hs.PXETag{} = noTH "toPat" p- toPat p@Hs.PXPcdata{} = noTH "toPat" p- toPat p@Hs.PXPatTag{} = noTH "toPat" p-#if MIN_VERSION_template_haskell(2,4,0)- toPat (Hs.PBangPat p) = BangP (toPat p)-#endif /* MIN_VERSION_template_haskell(2,4,0) */- toPat p = todo "toPat" p----------------------------------------------------------------------------------- * ToExp HsExp--instance ToExp Hs.QOp where- toExp (Hs.QVarOp n) = VarE (toName n)- toExp (Hs.QConOp n) = ConE (toName n)--toFieldExp :: Hs.FieldUpdate -> FieldExp-toFieldExp (Hs.FieldUpdate n e) = (toName n, toExp e)-----instance ToExp Hs.Exp where-{--data HsExp- = HsVar HsQName--}--- | HsIPVar HsIPName-{-- | HsLet HsBinds HsExp- | HsDLet [HsIPBind] HsExp- | HsWith HsExp [HsIPBind]- | HsCase HsExp [HsAlt]- | HsDo [HsStmt]- -- use mfix somehow- | HsMDo [HsStmt]--}- toExp (Hs.Var n) = VarE (toName n)- toExp (Hs.Con n) = ConE (toName n)- toExp (Hs.Lit l) = LitE (toLit l)-#if MIN_VERSION_template_haskell(2,7,0)- toExp (Hs.InfixApp e o f) = UInfixE (toExp e) (toExp o) (toExp f)-#else- toExp (Hs.InfixApp e o f) = InfixE (Just . toExp $ e) (toExp o) (Just . toExp $ f)-#endif- toExp (Hs.LeftSection e o) = InfixE (Just . toExp $ e) (toExp o) Nothing- toExp (Hs.RightSection o f) = InfixE Nothing (toExp o) (Just . toExp $ f)- toExp (Hs.App e f) = AppE (toExp e) (toExp f)- toExp (Hs.NegApp e) = AppE (VarE 'negate) (toExp e)- toExp (Hs.Lambda _ ps e) = LamE (fmap toPat ps) (toExp e)- toExp (Hs.Let bs e) = LetE (hsBindsToDecs bs) (toExp e)- -- toExp (HsWith e bs- toExp (Hs.If a b c) = CondE (toExp a) (toExp b) (toExp c)- toExp (Hs.Do ss) = DoE (map toStmt ss)- -- toExp (HsMDo ss)- toExp (Hs.Tuple xs) = TupE (fmap toExp xs)- toExp (Hs.List xs) = ListE (fmap toExp xs)-#if MIN_VERSION_template_haskell(2,7,0)- toExp (Hs.Paren e) = ParensE (toExp e)-#else- toExp (Hs.Paren e) = toExp e-#endif- toExp (Hs.RecConstr n xs) = RecConE (toName n) (fmap toFieldExp xs)- toExp (Hs.RecUpdate e xs) = RecUpdE (toExp e) (fmap toFieldExp xs)- toExp (Hs.EnumFrom e) = ArithSeqE $ FromR (toExp e)- toExp (Hs.EnumFromTo e f) = ArithSeqE $ FromToR (toExp e) (toExp f)- toExp (Hs.EnumFromThen e f) = ArithSeqE $ FromThenR (toExp e) (toExp f)- toExp (Hs.EnumFromThenTo e f g) = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g)- toExp (Hs.ExpTypeSig _ e t) = SigE (toExp e) (toType t)- -- HsListComp HsExp [HsStmt]- -- toExp (HsListComp e ss) = CompE- -- NEED: a way to go e -> Stmt-{- HsVarQuote HsQName- | HsTypQuote HsQName- | HsBracketExp HsBracket- | HsSpliceExp HsSplice-data HsBracket- = HsExpBracket HsExp- | HsPatBracket HsPat- | HsTypeBracket HsType- | HsDeclBracket [HsDecl]-data HsSplice = HsIdSplice String | HsParenSplice HsExp -}- toExp (Hs.Case e alts) = CaseE (toExp e) (map toMatch alts)- toExp e = todo "toExp" e---toMatch :: Hs.Alt -> Match-toMatch (Hs.Alt _ p galts ds) = Match (toPat p) (toBody galts) (toDecs ds)--toBody :: Hs.GuardedAlts -> Body-toBody (Hs.UnGuardedAlt e) = NormalB $ toExp e-toBody (Hs.GuardedAlts alts) = GuardedB $ do- Hs.GuardedAlt _ stmts e <- alts- let- g = case map toStmt stmts of- [NoBindS x] -> NormalG x- xs -> PatG xs- return (g, toExp e)--toGuard (Hs.GuardedAlt _ ([Hs.Qualifier e1]) e2) = (NormalG $ toExp e1,toExp e2)---------------------------------------------------------------------------------{--class ToName a where toName :: a -> Name-class ToLit a where toLit :: a -> Lit-class ToType a where toType :: a -> Type-class ToPat a where toPat :: a -> Pat-class ToExp a where toExp :: a -> Exp-class ToDec a where toDec :: a -> Dec-class ToStmt a where toStmt :: a -> Stmt-class ToLoc a where toLoc :: a -> Loc--}--{--TODO:- []--PARTIAL:- * ToExp HsExp- * ToStmt HsStmt- * ToDec HsDecl--DONE:- * ToLit HsLiteral- * ToName {..}- * ToPat HsPat- * ToLoc SrcLoc- * ToType HsType---}---------------------------------------------------------------------------------- * ToLoc SrcLoc--instance ToLoc Hs.SrcLoc where- toLoc (Hs.SrcLoc fn l c) =- Loc fn [] [] (l,c) (-1,-1)----------------------------------------------------------------------------------- * ToType HsType--instance ToName Hs.TyVarBind where- toName (Hs.KindedVar n _) = toName n- toName (Hs.UnkindedVar n) = toName n--instance ToName Name where- toName = id--#if MIN_VERSION_template_haskell(2,4,0)-instance ToName TyVarBndr where- toName (PlainTV n) = n- toName (KindedTV n _) = n-#endif /* !MIN_VERSION_template_haskell(2,4,0) */--#if MIN_VERSION_template_haskell(2,4,0)-toKind :: Hs.Kind -> Kind-toKind Hs.KindStar = StarK-toKind (Hs.KindFn k1 k2) = ArrowK (toKind k1) (toKind k2)-toKind (Hs.KindParen kp) = toKind kp-toKind k@Hs.KindBang = noTH "toKind" k-toKind k@Hs.KindVar{} = noTH "toKind" k-#endif /* !MIN_VERSION_template_haskell(2,4,0) */--#if MIN_VERSION_template_haskell(2,4,0)-toTyVar :: Hs.TyVarBind -> TyVarBndr-toTyVar (Hs.KindedVar n k) = KindedTV (toName n) (toKind k)-toTyVar (Hs.UnkindedVar n) = PlainTV (toName n)-#else /* !MIN_VERSION_template_haskell(2,4,0) */-toTyVar :: Hs.TyVarBind -> Name-toTyVar (Hs.KindedVar n _) = toName n-toTyVar (Hs.UnkindedVar n) = toName n-#endif /* !MIN_VERSION_template_haskell(2,4,0) */--{- |-TH does't handle- * unboxed tuples- * implicit params- * infix type constructors- * kind signatures--}-instance ToType Hs.Type where- toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t)- toType (Hs.TyFun a b) = toType a .->. toType b- toType (Hs.TyList t) = ListT `AppT` toType t- toType (Hs.TyTuple _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts)- toType (Hs.TyApp a b) = AppT (toType a) (toType b)- toType (Hs.TyVar n) = VarT (toName n)- toType (Hs.TyCon qn) = ConT (toName qn)- toType (Hs.TyParen t) = toType t- -- XXX: need to wrap the name in parens!- toType (Hs.TyInfix a o b) = AppT (AppT (ConT (toName o)) (toType a)) (toType b)- toType (Hs.TyKind t _) = toType t-----(.->.) :: Type -> Type -> Type-a .->. b = AppT (AppT ArrowT a) b--{- |-TH doesn't handle:- * implicit params--}--toCxt :: Hs.Context -> Cxt-toCxt = fmap toPred- where-#if MIN_VERSION_template_haskell(2,4,0)- toPred (Hs.ClassA n ts) = ClassP (toName n) (fmap toType ts)- toPred (Hs.InfixA t1 n t2) = ClassP (toName n) (fmap toType [t1, t2])- toPred (Hs.EqualP t1 t2) = EqualP (toType t1) (toType t2)- toPred a@Hs.IParam{} = noTH "toCxt" a-#else /* !MIN_VERSION_template_haskell(2,4,0) */- toPred (Hs.ClassA n ts) = foldAppT (ConT (toName n)) (fmap toType ts)- toPred (Hs.InfixA t1 n t2) = foldAppT (ConT (toName n)) (fmap toType [t1, t2])- toPred a@Hs.EqualP{} = noTH "toCxt" a- toPred a@Hs.IParam{} = noTH "toCxt" a-#endif /* !MIN_VERSION_template_haskell(2,4,0) */--foldAppT :: Type -> [Type] -> Type-foldAppT t ts = foldl' AppT t ts----------------------------------------------------------------------------------- * ToStmt HsStmt--instance ToStmt Hs.Stmt where- toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e)- toStmt (Hs.Qualifier e) = NoBindS (toExp e)- toStmt a@(Hs.LetStmt bnds) = LetS (hsBindsToDecs bnds)------------------------------------------------------------------------------------ * ToDec HsDecl---- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind]-hsBindsToDecs :: Hs.Binds -> [Dec]-hsBindsToDecs (Hs.BDecls ds) = fmap toDec ds-hsBindsToDecs a@Hs.IPBinds{} = noTH "hsBindsToDecs" a--- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp---hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type)-hsBangTypeToStrictType (Hs.BangedTy t) = (IsStrict, toType t)-hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)---{--data HsTyVarBind = HsKindedVar HsName HsKind | HsUnkindedVar HsName-data HsConDecl- = HsConDecl HsName [HsBangType]- | HsRecDecl HsName [([HsName], HsBangType)]--}-{--hsQualConDeclToCon :: HsQualConDecl -> Con-hsQualConDeclToCon (HsQualConDecl _ tvbs cxt condec) =- case condec of- HsConDecl n bangs ->- HsRecDecl n assocs ->--}-----instance ToDec Hs.Decl where- toDec (Hs.TypeDecl _ n ns t)- = TySynD (toName n) (fmap toTyVar ns) (toType t)--- toDec a@(Hs.DataDecl _ dOrN cxt n ns qcds qns)- = case dOrN of- Hs.DataType -> DataD (toCxt cxt)- (toName n)- (fmap toTyVar ns)- (fmap qualConDeclToCon qcds)- (fmap (toName . fst) qns)- Hs.NewType -> let qcd = case qcds of- [x] -> x- _ -> nonsense "toDec" ("newtype with " ++- "wrong number of constructors") dOrN- in NewtypeD (toCxt cxt)- (toName n)- (fmap toTyVar ns)- (qualConDeclToCon qcd)- (fmap (toName . fst) qns)---- data Hs.BangType--- = Hs.BangedTy Hs.Type--- | Hs.UnBangedTy Hs.Type--- | Hs.UnpackedTy Hs.Type--- data Hs.TyVarBind--- = Hs.KindedVar Hs.Name Hs.Kind | Hs.UnkindedVar Hs.Name--- data Hs.DataOrNew = Hs.DataType | Hs.NewType--- data Hs.QualConDecl--- = Hs.QualConDecl Hs.SrcLoc [Hs.TyVarBind] Hs.Context Hs.ConDecl--- data Hs.ConDecl--- = Hs.ConDecl Hs.Name [Hs.BangType]--- | Hs.RecDecl Hs.Name [([Hs.Name], Hs.BangType)]---- data Con--- = NormalC Name [StrictType]--- | RecC Name [VarStrictType]--- | InfixC StrictType Name StrictType--- | ForallC [Name] Cxt Con--- type StrictType = (Strict, Type)--- type VarStrictType = (Name, Strict, Type)--- -- This type-signature conversion is just wrong. - -- Type variables need to be dealt with. /Jonas- toDec a@(Hs.TypeSig _ ns t)- -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class!- = let xs = fmap (flip SigD (toType t) . toName) ns- in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!"-#if MIN_VERSION_template_haskell(2,4,0)- toDec (Hs.InlineConlikeSig _ act id) = PragmaD $ - InlineP (toName id) (InlineSpec True True $ transAct act)- toDec (Hs.InlineSig _ b act id) = PragmaD $ - InlineP (toName id) (InlineSpec b False $ transAct act)-#endif /* MIN_VERSION_template_haskell(2,4,0) */--{- data HsDecl = ... | HsFunBind [HsMatch] | ...-data HsMatch = HsMatch SrcLoc HsName [HsPat] HsRhs HsBinds-data Dec = FunD Name [Clause] | ...-data Clause = Clause [Pat] Body [Dec] -}- toDec a@(Hs.FunBind mtchs) = hsMatchesToFunD mtchs-{- ghci> parseExp "let x = 2 in x"-LetE [ValD (VarP x) (NormalB (LitE (IntegerL 2))) []] (VarE x)-ghci> unQ[| let x = 2 in x |]-LetE [ValD (VarP x_0) (NormalB (LitE (IntegerL 2))) []] (VarE x_0) -}- toDec (Hs.PatBind _ p tM rhs bnds) = ValD ((maybe id- (flip SigP . toType)- tM) (toPat p))- (hsRhsToBody rhs)- (hsBindsToDecs bnds)-- toDec (Hs.InstDecl _ cxt qname ts ids) = InstanceD - (toCxt cxt) - (foldl AppT (ConT (toName qname)) (map toType ts))- (toDecs ids)- - toDec x = todo "toDec" x----- data Hs.Decl = ... | Hs.SpliceDecl Hs.SrcLoc Hs.Splice | ...--- data Hs.Splice = Hs.IdSplice String | Hs.ParenSplice Hs.Exp--transAct act = case act of- Hs.AlwaysActive -> Nothing- Hs.ActiveFrom n -> Just (True,n)- Hs.ActiveUntil n -> Just (False,n)---------qualConDeclToCon :: Hs.QualConDecl -> Con-qualConDeclToCon (Hs.QualConDecl _ [] [] cdecl) = conDeclToCon cdecl-qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toTyVar ns)- (toCxt cxt)- (conDeclToCon cdecl)--conDeclToCon :: Hs.ConDecl -> Con-conDeclToCon (Hs.ConDecl n tys)- = NormalC (toName n) (fmap bangToStrictType tys)-conDeclToCon (Hs.RecDecl n lbls)- = RecC (toName n) (concatMap (uncurry bangToVarStrictTypes) lbls)----bangToVarStrictTypes :: [Hs.Name] -> Hs.BangType -> [VarStrictType]-bangToVarStrictTypes ns t = let (a,b) = bangToStrictType t- in fmap (\n->(toName n,a,b)) ns--bangToStrictType :: Hs.BangType -> StrictType-bangToStrictType (Hs.BangedTy t) = (IsStrict, toType t)-bangToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)-bangToStrictType (Hs.UnpackedTy t) = (IsStrict, toType t)---hsMatchesToFunD :: [Hs.Match] -> Dec-hsMatchesToFunD [] = FunD (mkName []) [] -- errorish-hsMatchesToFunD xs@(Hs.Match _ n _ _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)---hsMatchToClause :: Hs.Match -> Clause-hsMatchToClause (Hs.Match _ _ ps _ rhs bnds) = Clause- (fmap toPat ps)- (hsRhsToBody rhs)- (hsBindsToDecs bnds)------ data HsRhs = HsUnGuardedRhs HsExp | HsGuardedRhs [HsGuardedRhs]--- data HsGuardedRhs = HsGuardedRhs SrcLoc [HsStmt] HsExp--- data Body = GuardedB [(Guard, Exp)] | NormalB Exp--- data Guard = NormalG Exp | PatG [Stmt]-hsRhsToBody :: Hs.Rhs -> Body-hsRhsToBody (Hs.UnGuardedRhs e) = NormalB (toExp e)-hsRhsToBody (Hs.GuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a- in GuardedB . concat- . fmap (fromGuardedB . hsGuardedRhsToBody)- $ hsgrhs----hsGuardedRhsToBody :: Hs.GuardedRhs -> Body-hsGuardedRhsToBody (Hs.GuardedRhs _ [] e) = NormalB (toExp e)-hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]-hsGuardedRhsToBody (Hs.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss- (pgs,ngs) = unzip [(p,n)- | (PatG p) <- ss'- , n@(NormalG _) <- ss']- e' = toExp e- patg = PatG (concat pgs)- in GuardedB $ (patg,e') : zip ngs (repeat e')----hsStmtToGuard :: Hs.Stmt -> Guard-hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)]-hsStmtToGuard (Hs.Qualifier e) = NormalG (toExp e)-hsStmtToGuard (Hs.LetStmt bs) = PatG [LetS (hsBindsToDecs bs)]------------------------------------------------------------------------------------ * ToDecs InstDecl-instance ToDecs Hs.InstDecl where- toDecs (Hs.InsDecl decl) = toDecs decl- toDecs d = todo "toDec" d---- * ToDecs HsDecl HsBinds--instance ToDecs Hs.Decl where--- toDecs a@(Hs.InfixDecl _ asst i ops) = [] -- HACK--- toDecs (Hs.InlineSig _ _ _ _) = [] -- HACK- toDecs a@(Hs.TypeSig _ ns t)- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns- in xs--- toDecs a = [toDec a]--collectVars e = case e of-#if MIN_VERSION_template_haskell(2,4,0)- VarT n -> [PlainTV n]-#else /* !MIN_VERSION_template_haskell(2,4,0) */- VarT n -> [n]-#endif /* !MIN_VERSION_template_haskell(2,4,0) */- AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2- ForallT ns _ t -> collectVars t \\ ns- _ -> []--fixForall t = case vs of- [] -> t- _ -> ForallT vs [] t- where vs = collectVars t--instance ToDecs a => ToDecs [a] where- toDecs a = concatMap toDecs a--instance ToDecs Hs.Binds where- toDecs (Hs.BDecls ds) = toDecs ds--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++{- |+ Module : Language.Haskell.Meta.Syntax.Translate+ Copyright : (c) Matt Morrow 2008+ License : BSD3+ Maintainer : Matt Morrow <mjm2002@gmail.com>+ Stability : experimental+ Portability : portable (template-haskell)+-}++module Language.Haskell.Meta.Syntax.Translate (+ module Language.Haskell.Meta.Syntax.Translate+ , 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++-- TODO (int-index): Use MIN_VERSION_template_haskell(2,21,0)+#if __GLASGOW_HASKELL__ >= 907+toTyVarsVis :: ToTyVars a => a -> [TH.TyVarBndrVis]+toTyVarsVis = map toTyVarVis . toTyVars+ where+ toTyVarVis (TH.KindedTV n () k) = TH.KindedTV n TH.BndrReq k+ toTyVarVis (TH.PlainTV n ()) = TH.PlainTV n TH.BndrReq+#else+toTyVarsVis :: ToTyVars a => a -> [TyVarBndr_ ()]+toTyVarsVis = toTyVars+#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) (toTyVarsVis h) (toType t)++ toDec a@(Exts.DataDecl _ dOrN cxt h qcds qns)+ = case dOrN of+ Exts.DataType _ -> TH.DataD (toCxt cxt)+ (toName h)+ (toTyVarsVis 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)+ (toTyVarsVis 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)+ (toTyVarsVis h)+ (maybe TH.NoSig TH.KindSig . toMaybeKind $ sig)+ (fmap toInjectivityAnn inj)+ toDec (Exts.DataFamDecl _ _ h sig)+ = TH.DataFamilyD (toName h) (toTyVarsVis 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)+ (toTyVarsVis 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) =+#if MIN_VERSION_template_haskell(2,22,0)+ map (\op -> TH.InfixD (TH.Fixity fixity dir) TH.NoNamespaceSpecifier (toName op)) ops+#else+ map (\op -> TH.InfixD (TH.Fixity fixity dir) (toName op)) ops+#endif+ 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
+ src/Language/Haskell/Meta/THCompat.hs view
@@ -0,0 +1,30 @@+{-# 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
src/Language/Haskell/Meta/Utils.hs view
@@ -1,29 +1,77 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell, RankNTypes, StandaloneDeriving,- DeriveDataTypeable, PatternGuards, FlexibleContexts, FlexibleInstances,- TypeSynonymInstances #-}+{-# 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 where+module Language.Haskell.Meta.Utils (+ module Language.Haskell.Meta.Utils+) where -import Data.Typeable-import Data.Generics hiding(Fixity)-import Language.Haskell.Meta-import System.IO.Unsafe(unsafePerformIO)-import Language.Haskell.Exts.Pretty(prettyPrint)-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Lift (deriveLift)-import Language.Haskell.TH.Ppr-import Text.PrettyPrint-import Control.Monad+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 _ = []++#if !MIN_VERSION_template_haskell(2,21,0)+#if __GLASGOW_HASKELL__ < 900+type TyVarBndrVis = TyVarBndr_ ()+#else+type TyVarBndrVis = TyVarBndrUnit+#endif+#endif++decTyVars :: Dec -> [TyVarBndrVis]+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@@ -32,7 +80,7 @@ | otherwise = (mkName . nameBase) n isNameU :: Name -> Bool isNameU (Name _ (NameU _)) = True- isNameU _ = False+ isNameU _ = False -- | The type passed in must have a @Show@ instance which@@ -41,7 +89,7 @@ -- but useful in general. pretty :: (Show a) => a -> String pretty a = case parseHsExp (show a) of- Left _ -> []+ Left _ -> [] Right e -> prettyPrint e @@ -56,38 +104,34 @@ gpretty = either (const []) prettyPrint . parseHsExp . gshow -instance Show ExpQ where show = show . cleanNames . unQ-instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unQ-instance Show DecQ where show = show . cleanNames . unQ-instance Show TypeQ where show = show . cleanNames . unQ-instance Show (Q String) where show = unQ-instance Show (Q Doc) where show = show . unQ--deriving instance Typeable1 Q-deriving instance Typeable QuasiQuoter-+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 --- | @unQ = unsafePerformIO . runQ@-unQ :: Q a -> a-unQ = unsafePerformIO . runQ+-- | @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 VarName -> "'"++s+ Just DataName -> "'"++s Just TcClsName -> "''"++s- _ -> concat ["(mkName \"", filter (/='"') s, "\")"]+ _ -> concat ["(mkName \"", filter (/='"') s, "\")"] where showNameParens :: Name -> String- showNameParens n =- let nb = nameBase n+ showNameParens n' =+ let nb = nameBase n' in case nb of (c:_) | isSym c -> concat ["(",nb,")"]- _ -> nb+ _ -> nb isSym :: Char -> Bool- isSym = (`elem` "><.\\/!@#$%^&*-+?:|")+ isSym = (`elem` ("><.\\/!@#$%^&*-+?:|" :: [Char])) -----------------------------------------------------------------------------@@ -109,7 +153,7 @@ unForall :: Type -> Type unForall (ForallT _ _ t) = t-unForall t = t+unForall t = t functionT :: [TypeQ] -> TypeQ functionT = foldl1 (|->|)@@ -125,6 +169,8 @@ 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@@ -141,7 +187,7 @@ -- 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 [] _ = 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)@@ -159,24 +205,11 @@ (t',env4,new4) = renameT env3 new3 t in (ForallT ns'' cxt' t', env4, new4) where-#if MIN_VERSION_template_haskell(2,4,0)- unVarT (VarT n) = PlainTV n+ unVarT (VarT n) = Compat.plainTV n+ unVarT ty = error $ "renameT: unVarT: TODO for" ++ show ty renamePreds = renameThings renamePred-- renamePred env new (ClassP n ts) = let- (ts', env', new') = renameTs env new [] ts- in (ClassP (normaliseName n) ts', env', new')-- renamePred env new (EqualP t1 t2) = let- (t1', env1, new1) = renameT env new t1- (t2', env2, new2) = renameT env1 new1 t2- in (EqualP t1' t2', env2, new2)--#else /* !MIN_VERSION_template_haskell(2,4,0) */- unVarT (VarT n) = n- renamePreds = renameTs--#endif /* !MIN_VERSION_template_haskell(2,4,0) */+ renamePred = renameT+renameT _ _ t = error $ "renameT: TODO for " ++ show t -- | Remove qualification, etc. normaliseName :: Name -> Name@@ -203,17 +236,6 @@ --- | Produces pretty code suitable--- for human consumption.-deriveLiftPretty :: Name -> Q String-deriveLiftPretty n = do- decs <- deriveLift n- case (parseHsDecls . pprint . cleanNames) decs of- Left e -> fail ("deriveLiftPretty: error while prettifying code: "++e)- Right hsdecs -> return (unlines . fmap prettyPrint $ hsdecs)--- splitCon :: Con -> (Name,[Type]) splitCon c = (conName c, conTypes c) @@ -230,6 +252,10 @@ 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@@ -237,52 +263,19 @@ -decCons :: Dec -> [Con]-decCons (DataD _ _ _ cons _) = cons-decCons (NewtypeD _ _ _ con _) = [con]-decCons _ = [] --#if MIN_VERSION_template_haskell(2,4,0)-decTyVars :: Dec -> [TyVarBndr]-#else /* !MIN_VERSION_template_haskell(2,4,0) */-decTyVars :: Dec -> [Name]-#endif /* !MIN_VERSION_template_haskell(2,4,0) */-decTyVars (DataD _ _ ns _ _) = ns-decTyVars (NewtypeD _ _ ns _ _) = ns-decTyVars (TySynD _ ns _) = ns-decTyVars (ClassD _ _ ns _ _) = ns-decTyVars _ = []---decName :: Dec -> Maybe Name-decName (FunD n _) = Just n-decName (DataD _ n _ _ _) = Just n-decName (NewtypeD _ n _ _ _) = Just n-decName (TySynD n _ _) = Just n-decName (ClassD _ n _ _ _) = Just n-decName (SigD n _) = Just n-decName (ForeignD fgn) = Just (foreignName fgn)-decName _ = Nothing---foreignName :: Foreign -> Name-foreignName (ImportF _ _ _ n _) = n-foreignName (ExportF _ _ n _) = n-- unwindT :: Type -> [Type] unwindT = go where go :: Type -> [Type]- go (ForallT _ _ t) = go t+ go (ForallT _ _ t) = go t go (AppT (AppT ArrowT t) t') = t : go t'- go _ = []+ go _ = [] unwindE :: Exp -> [Exp] unwindE = go [] where go acc (e `AppE` e') = go (e':acc) e- go acc e = e:acc+ go acc e = e:acc -- | The arity of a Type.@@ -306,34 +299,39 @@ -- | Randomly useful. nameSpaceOf :: Name -> Maybe NameSpace nameSpaceOf (Name _ (NameG ns _ _)) = Just ns-nameSpaceOf _ = Nothing+nameSpaceOf _ = Nothing conName :: Con -> Name-conName (RecC n _) = n-conName (NormalC n _) = n-conName (InfixC _ n _) = n+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--dataDCons :: Dec -> [Con]-dataDCons (DataD _ _ _ cons _) = cons-dataDCons _ = []+recCName _ = Nothing fromDataConI :: Info -> Q (Maybe Exp)-fromDataConI (DataConI dConN ty tyConN fxty) =+fromDataConI (DataConI dConN ty _tyConN) = let n = arityT ty in replicateM n (newName "a") >>= \ns -> return (Just (LamE- [ConP dConN (fmap VarP ns)]- (TupE $ fmap VarE ns)))+ [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+fromTyConI _ = Nothing mkFunD :: Name -> [Pat] -> Exp -> Dec mkFunD f xs e = FunD f [Clause xs (NormalB e) []]@@ -389,134 +387,12 @@ where go :: Type -> Type go (ConT n) | n == ''[] = ListT go (AppT (TupleT 1) t) = t- go (ConT n) | n == ''(,) = TupleT 2- go (ConT n) | n == ''(,,) = TupleT 3- go (ConT n) | n == ''(,,,) = TupleT 4- go (ConT n) | n == ''(,,,,) = TupleT 5- go (ConT n) | n == ''(,,,,,) = TupleT 6- go (ConT n) | n == ''(,,,,,,) = TupleT 7- go (ConT n) | n == ''(,,,,,,,) = TupleT 8- go (ConT n) | n == ''(,,,,,,,,) = TupleT 9- go (ConT n) | n == ''(,,,,,,,,,) = TupleT 10- go (ConT n) | n == ''(,,,,,,,,,,) = TupleT 11- go (ConT n) | n == ''(,,,,,,,,,,,) = TupleT 12- go (ConT n) | n == ''(,,,,,,,,,,,,) = TupleT 13- go (ConT n) | n == ''(,,,,,,,,,,,,,) = TupleT 14- go (ConT n) | n == ''(,,,,,,,,,,,,,,) = TupleT 15- go (ConT n) | n == ''(,,,,,,,,,,,,,,,) = TupleT 16- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,) = TupleT 17- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,) = TupleT 18- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,) = TupleT 19- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,) = TupleT 20- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,) = TupleT 21- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,) = TupleT 22- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,) = TupleT 23- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 24- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 25- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 26- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 27- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 28- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 29- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 30- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 31- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 32- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 33- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 34- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 35- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 36- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 37- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 38- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 39- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 40- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 41- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 42- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 43- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 44- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 45- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 46- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 47- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 48- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 49- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 50- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 51- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 52- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 53- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 54- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 55- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 56- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 57- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 58- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 59- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 60- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 61- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 62- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 63- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 64+ go (ConT n)+ | Just m <- findIndex (== n) tupleNames = TupleT (m + 2)+ where+ tupleNames = map tupleTypeName [2 .. 64] go t = t --------------------------------------------------------------------------------------------------------------------------------------------
− src/Language/Haskell/TH/Instances/Lift.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving, TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}--{- |- Module : Language.Haskell.TH.Instances.Lift- Copyright : (c) Matt Morrow 2008- License : BSD3- Maintainer : Matt Morrow <mjm2002@gmail.com>- Stability : experimental- Portability : portable (template-haskell)--}--module Language.Haskell.TH.Instances.Lift () where--import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Lift (deriveLiftMany)--deriving instance Ord Exp-deriving instance Ord Dec-deriving instance Ord Stmt-deriving instance Ord Type-deriving instance Ord Foreign-deriving instance Ord FunDep-deriving instance Ord Con-deriving instance Ord Body-deriving instance Ord Clause-deriving instance Ord Strict-deriving instance Ord Safety-deriving instance Ord Callconv-deriving instance Ord Guard-deriving instance Ord Range-deriving instance Ord Match-deriving instance Ord Pat-deriving instance Ord Lit--#if MIN_VERSION_template_haskell(2,4,0)-deriving instance Ord TyVarBndr-deriving instance Ord Pred-deriving instance Ord Kind-deriving instance Ord FamFlavour-deriving instance Ord InlineSpec-deriving instance Ord Pragma-#endif /* MIN_VERSION_template_haskell(2,4,0) */--deriving instance Show Loc-deriving instance Eq Loc---- TODO: make this better-instance Ppr Loc where- ppr = showtextl . show--instance Ppr Lit where- ppr l = ppr (LitE l)--$(deriveLiftMany [ ''Body- , ''Callconv- , ''Clause- , ''Con- , ''Dec- , ''Exp- , ''Fixity- , ''FixityDirection- , ''Foreign- , ''FunDep- , ''Guard- , ''Info- , ''Lit- , ''Match- , ''Pat- , ''Range- , ''Safety- , ''Stmt- , ''Strict- , ''Type-#if MIN_VERSION_template_haskell(2,4,0)- , ''FamFlavour- , ''InlineSpec- , ''Kind- , ''Pragma- , ''Pred- , ''TyVarBndr-#if MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0))- , ''ClassInstance-#endif /* MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0)) */-#endif /* MIN_VERSION_template_haskell(2,4,0) */- ])-
+ tests/Main.hs view
@@ -0,0 +1,89 @@+{-# 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
+ tests/Splices.hs view
@@ -0,0 +1,78 @@+{-# 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 ()
+ tests/TestExamples.hs view
@@ -0,0 +1,53 @@+{-# 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