haskell-src-meta 0.7.0.1 → 0.8.16
raw patch · 18 files changed
Files
- ChangeLog +68/−1
- README.md +4/−1
- examples/BF.hs +55/−23
- examples/Hs.hs +17/−3
- examples/HsHere.hs +56/−24
- examples/SKI.hs +56/−26
- haskell-src-meta.cabal +65/−25
- src/Language/Haskell/Meta.hs +3/−1
- src/Language/Haskell/Meta/Extensions.hs +407/−0
- src/Language/Haskell/Meta/Parse.hs +33/−30
- src/Language/Haskell/Meta/Parse/Careful.hs +0/−60
- src/Language/Haskell/Meta/Syntax/Translate.hs +828/−735
- src/Language/Haskell/Meta/THCompat.hs +30/−0
- src/Language/Haskell/Meta/Utils.hs +106/−118
- src/Language/Haskell/TH/Instances/Lift.hs +0/−16
- tests/Main.hs +89/−0
- tests/Splices.hs +78/−0
- tests/TestExamples.hs +53/−0
ChangeLog view
@@ -1,9 +1,76 @@+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 +- 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:
README.md view
@@ -1,4 +1,4 @@-The `haskell-src-meta` Package [](https://hackage.haskell.org/package/haskell-src-meta) [](https://travis-ci.org/mainland/haskell-src-meta)+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@@ -11,3 +11,6 @@ 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,48 +1,88 @@ name: haskell-src-meta-version: 0.7.0.1-cabal-version: >= 1.6+version: 0.8.16+cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: LICENSE category: Language, Template Haskell author: Matt Morrow copyright: (c) Matt Morrow-maintainer: Ben Millwood <haskell@benmachine.co.uk>-bug-reports: https://github.com/bmillwood/haskell-src-meta/issues--- That is to say, "builds with". It's not like we have a testsuite.-tested-with: GHC == 7.6.3, GHC == 7.8.3, GHC == 7.10.3, GHC == 8.0.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: ChangeLog README.md examples/*.hs+extra-source-files: ChangeLog README.md library- build-depends: base >= 4.5 && < 4.10,- haskell-src-exts >= 1.17 && < 1.19,+ 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.7,- template-haskell >= 2.7 && < 2.12,- th-orphans >= 0.9.1 && < 0.14+ 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/bmillwood/haskell-src-meta.git-+ location: https://github.com/haskell-party/haskell-src-meta.git
src/Language/Haskell/Meta.hs view
@@ -8,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()+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
@@ -13,11 +13,13 @@ parseExp, parseType, parseDecs,+ parseDecsWithMode, myDefaultParseMode, myDefaultExtensions, parseResultToEither, parseHsModule, parseHsDecls,+ parseHsDeclsWithMode, parseHsType, parseHsExp, parseHsPat,@@ -27,55 +29,45 @@ emptyHsModule ) where -#if MIN_VERSION_template_haskell(2,11,0)-import Language.Haskell.TH.Syntax hiding (Extension(..))-#else-import Language.Haskell.TH.Syntax-#endif-import Language.Haskell.Meta.Syntax.Translate-#if MIN_VERSION_haskell_src_exts(1,18,0)-import qualified Language.Haskell.Exts.Syntax as Hs-import Language.Haskell.Exts.Fixity as Fix-import Language.Haskell.Exts.Parser hiding (parseExp, parseType, parsePat)-#else-import qualified Language.Haskell.Exts.Annotated.Syntax as Hs-import Language.Haskell.Exts.Annotated.Fixity as Fix-import Language.Haskell.Exts.Annotated.Parser hiding (parseExp, parseType, parsePat)-#endif-import qualified Language.Haskell.Exts.SrcLoc as Hs-import Language.Haskell.Exts.Extension-import Language.Haskell.Exts.Pretty-import Language.Haskell.Exts.Parser (ParseMode(..), ParseResult(..))+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 = [] ,baseLanguage = Haskell2010 ,extensions = map EnableExtension myDefaultExtensions- ,ignoreLinePragmas = False- ,ignoreLanguagePragmas = False- ,fixities = Nothing- ,ignoreFunctionArity = False } myDefaultExtensions :: [KnownExtension]@@ -88,7 +80,8 @@ ,TemplateHaskell ,RankNTypes ,MultiParamTypeClasses- ,RecursiveDo]+ ,RecursiveDo+ ,TypeApplications] parseResultToEither :: ParseResult a -> Either String a parseResultToEither (ParseOk a) = Right a@@ -100,10 +93,15 @@ parseHsModule = parseResultToEither . parseModuleWithMode myDefaultParseMode parseHsDecls :: String -> Either String [Hs.Decl Hs.SrcSpanInfo]-parseHsDecls = either Left (Right . moduleDecls)+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 Hs.SrcSpanInfo) parseHsType = parseResultToEither . parseTypeWithMode myDefaultParseMode @@ -120,6 +118,10 @@ 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 [] []@@ -133,6 +135,7 @@ [] []) +noSrcSpanInfo :: Hs.SrcSpanInfo noSrcSpanInfo = Hs.noInfoSpan (Hs.mkSrcSpan Hs.noLoc Hs.noLoc) {-
− src/Language/Haskell/Meta/Parse/Careful.hs
@@ -1,60 +0,0 @@-{- |-DEPRECATED: haskell-src-meta now requires GHC >= 7.4, so this module is no longer necessary. It will be GHC-warning deprecated soon.--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--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---- This was more complicated, but since support for GHC pre-7.4 was dropped,--- it's no longer necessary-amb = const False
src/Language/Haskell/Meta/Syntax/Translate.hs view
@@ -1,735 +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.Char (ord)-import Data.Typeable-import Data.List (foldl', nub, (\\))-import Language.Haskell.TH.Syntax-import qualified Language.Haskell.Exts.SrcLoc as Hs-#if MIN_VERSION_haskell_src_exts(1,18,0)-import qualified Language.Haskell.Exts.Syntax as Hs-#else-import qualified Language.Haskell.Exts.Annotated.Syntax as Hs-#endif----------------------------------------------------------------------------------class ToName a where toName :: a -> Name-class ToNames a where toNames :: 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-class ToCxt a where toCxt :: a -> Cxt-class ToPred a where toPred :: a -> Pred-class ToTyVars a where toTyVars :: a -> [TyVarBndr]-#if MIN_VERSION_haskell_src_exts(1,18,0)-class ToMaybeKind a where toMaybeKind :: a -> Maybe Kind-#if MIN_VERSION_template_haskell(2,11,0)-class ToInjectivityAnn a where toInjectivityAnn :: a -> InjectivityAnn-#endif-#endif---- for error messages-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)]----------------------------------------------------------------------------------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 l) where- toName (Hs.Ident _ s) = toName s- toName (Hs.Symbol _ s) = toName s--instance ToName (Hs.SpecialCon l) 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 l) 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---instance ToName (Hs.Op l) where- toName (Hs.VarOp _ n) = toName n- toName (Hs.ConOp _ n) = toName n------------------------------------------------------------------------------------ * ToLit HsLiteral---instance ToLit (Hs.Literal l) 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 l@Hs.PrimChar{} = noTH "toLit" l- toLit (Hs.PrimString _ a _) = StringPrimL (map toWord8 a)- where- toWord8 = fromIntegral . ord- toLit (Hs.PrimInt _ a _) = IntPrimL a- toLit (Hs.PrimFloat _ a _) = FloatPrimL a- toLit (Hs.PrimDouble _ a _) = DoublePrimL a- toLit (Hs.PrimWord _ a _) = WordPrimL a------------------------------------------------------------------------------------ * ToPat HsPat---instance ToPat (Hs.Pat l) where- toPat (Hs.PVar _ n)- = VarP (toName n)- toPat (Hs.PLit _ (Hs.Signless _) l)- = LitP (toLit l)- toPat (Hs.PLit _ (Hs.Negative _) 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.PInfixApp _ p n q) = UInfixP (toPat p) (toName n) (toPat q)- toPat (Hs.PApp _ n ps) = ConP (toName n) (fmap toPat ps)- toPat (Hs.PTuple _ Hs.Boxed ps) = TupP (fmap toPat ps)- toPat (Hs.PTuple _ Hs.Unboxed ps) = UnboxedTupP (fmap toPat ps)- toPat (Hs.PList _ ps) = ListP (fmap toPat ps)- toPat (Hs.PParen _ p) = ParensP (toPat p)- toPat (Hs.PRec _ n pfs) = let toFieldPat (Hs.PFieldPat _ n p) = (toName n, toPat p)- in RecP (toName n) (fmap toFieldPat pfs)- toPat (Hs.PAsPat _ n p) = AsP (toName n) (toPat p)- toPat (Hs.PWildCard _) = WildP- toPat (Hs.PIrrPat _ p) = TildeP (toPat p)- toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t)- toPat (Hs.PViewPat _ e p) = ViewP (toExp e) (toPat p)- -- 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- toPat (Hs.PBangPat _ p) = BangP (toPat p)- toPat p = todo "toPat" p----------------------------------------------------------------------------------- * ToExp HsExp--instance ToExp (Hs.QOp l) where- toExp (Hs.QVarOp _ n) = VarE (toName n)- toExp (Hs.QConOp _ n) = ConE (toName n)--toFieldExp :: Hs.FieldUpdate l -> FieldExp-toFieldExp (Hs.FieldUpdate _ n e) = (toName n, toExp e)-----instance ToExp (Hs.Exp l) where- toExp (Hs.Var _ n) = VarE (toName n)- toExp e@Hs.IPVar{} = noTH "toExp" e- toExp (Hs.Con _ n) = ConE (toName n)- toExp (Hs.Lit _ l) = LitE (toLit l)- toExp (Hs.InfixApp _ e o f) = UInfixE (toExp e) (toExp o) (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 (toDecs bs) (toExp e)- toExp (Hs.If _ a b c) = CondE (toExp a) (toExp b) (toExp c)- toExp (Hs.MultiIf _ ifs) = MultiIfE (map toGuard ifs)- toExp (Hs.Case _ e alts) = CaseE (toExp e) (map toMatch alts)- toExp (Hs.Do _ ss) = DoE (map toStmt ss)- toExp e@(Hs.MDo _ _) = noTH "toExp" e- toExp (Hs.Tuple _ Hs.Boxed xs) = TupE (fmap toExp xs)- toExp (Hs.Tuple _ Hs.Unboxed xs) = UnboxedTupE (fmap toExp xs)- toExp e@Hs.TupleSection{} = noTH "toExp" e- toExp (Hs.List _ xs) = ListE (fmap toExp xs)- toExp (Hs.Paren _ e) = ParensE (toExp e)- 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.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.ListComp _ e ss) = CompE $ map convert ss ++ [NoBindS (toExp e)]- where- convert (Hs.QualStmt _ st) = toStmt st- convert s = noTH "toExp ListComp" s- toExp (Hs.ExpTypeSig _ e t) = SigE (toExp e) (toType t)- toExp e = todo "toExp" e---toMatch :: Hs.Alt l -> Match-toMatch (Hs.Alt _ p rhs ds) = Match (toPat p) (toBody rhs) (toDecs ds)--toBody :: Hs.Rhs l -> Body-toBody (Hs.UnGuardedRhs _ e) = NormalB $ toExp e-toBody (Hs.GuardedRhss _ rhss) = GuardedB $ map toGuard rhss--toGuard (Hs.GuardedRhs _ stmts e) = (g, toExp e)- where- g = case map toStmt stmts of- [NoBindS x] -> NormalG x- xs -> PatG xs--instance ToDecs a => ToDecs (Maybe a) where- toDecs Nothing = []- toDecs (Just a) = toDecs a--instance ToDecs (Hs.Binds l) where- toDecs (Hs.BDecls _ ds) = toDecs ds- toDecs a@(Hs.IPBinds {}) = noTH "ToDecs Hs.Binds" a--instance ToDecs (Hs.ClassDecl l) where- toDecs (Hs.ClsDecl _ d) = toDecs d- toDecs x = todo "classDecl" x----------------------------------------------------------------------------------- * 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 l) where- toName (Hs.KindedVar _ n _) = toName n- toName (Hs.UnkindedVar _ n) = toName n--instance ToName Name where- toName = id--instance ToName TyVarBndr where- toName (PlainTV n) = n- toName (KindedTV n _) = n--instance ToType (Hs.Kind l) where- toType (Hs.KindStar _) = StarT- toType (Hs.KindFn _ k1 k2) = toType k1 .->. toType k2- toType (Hs.KindParen _ kp) = toType kp- toType (Hs.KindVar _ n) = VarT (toName n)--toKind :: Hs.Kind l -> Kind-toKind = toType--toTyVar :: Hs.TyVarBind l -> TyVarBndr-toTyVar (Hs.KindedVar _ n k) = KindedTV (toName n) (toKind k)-toTyVar (Hs.UnkindedVar _ n) = PlainTV (toName n)--instance ToType (Hs.Type l) 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 _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts)- where- tuple = case b of- Hs.Boxed -> TupleT- Hs.Unboxed -> UnboxedTupleT- 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 k) = SigT (toType t) (toKind k)- toType t@Hs.TyBang{} =- nonsense "toType" "type cannot have strictness annotations in this context" t---toStrictType :: Hs.Type l -> StrictType-#if MIN_VERSION_haskell_src_exts(1,18,0)-#if MIN_VERSION_template_haskell(2,11,0)-toStrictType (Hs.TyBang _ s u t) = (Bang (toUnpack u) (toStrict s), toType t)- where- toStrict (Hs.LazyTy _) = SourceLazy- toStrict (Hs.BangedTy _) = SourceStrict- toStrict (Hs.NoStrictAnnot _) = NoSourceStrictness- toUnpack (Hs.Unpack _) = SourceUnpack- toUnpack (Hs.NoUnpack _) = SourceNoUnpack- toUnpack (Hs.NoUnpackPragma _) = NoSourceUnpackedness-toStrictType x = (Bang NoSourceUnpackedness NoSourceStrictness, toType x)-#else--- TyBang l (BangType l) (Unpackedness l) (Type l)--- data BangType l = BangedTy l | LazyTy l | NoStrictAnnot l--- data Unpackedness l = Unpack l | NoUnpack l | NoUnpackPragma l-toStrictType (Hs.TyBang _ b u t) = (toStrict b u, toType t)- where- toStrict :: Hs.BangType l -> Hs.Unpackedness l -> Strict- toStrict (Hs.BangedTy _) _ = IsStrict- toStrict _ (Hs.Unpack _) = Unpacked- toStrict _ _ = NotStrict-toStrictType x = (NotStrict, toType x)-#endif-#else-#if MIN_VERSION_template_haskell(2,11,0)-toStrictType (Hs.TyBang _ (Hs.UnpackedTy _) t) = toStrictType2 SourceUnpack t-toStrictType t = toStrictType2 NoSourceUnpackedness t--toStrictType2 u t@(Hs.TyBang _ _ Hs.TyBang{}) =- nonsense "toStrictType" "double strictness annotation" t-toStrictType2 u (Hs.TyBang _ (Hs.BangedTy _) t) = (Bang u SourceStrict, toType t)-toStrictType2 u (Hs.TyBang _ (Hs.UnpackedTy _) t) =- nonsense "toStrictType" "double unpackedness annotation" t-toStrictType2 u t = (Bang u NoSourceStrictness, toType t)-#else /* !MIN_VERSION_template_haskell(2,11,0) */-toStrictType t@(Hs.TyBang _ _ Hs.TyBang{}) =- nonsense "toStrictType" "double strictness annotation" t-toStrictType (Hs.TyBang _ (Hs.BangedTy _) t) = (IsStrict, toType t)-toStrictType (Hs.TyBang _ (Hs.UnpackedTy _) t) = (Unpacked, toType t)-toStrictType t = (NotStrict, toType t)-#endif /* !MIN_VERSION_template_haskell(2,11,0) */-#endif---(.->.) :: Type -> Type -> Type-a .->. b = AppT (AppT ArrowT a) b--instance ToPred (Hs.Asst l) where-#if MIN_VERSION_template_haskell(2,10,0)- toPred (Hs.ClassA _ n ts) = foldl' AppT (ConT (toName n)) (fmap toType ts)- toPred (Hs.InfixA _ t1 n t2) = foldl' AppT (ConT (toName n)) (fmap toType [t1,t2])- toPred (Hs.EqualP _ t1 t2) = foldl' AppT EqualityT (fmap toType [t1,t2])-#else- 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)-#endif- toPred a@Hs.IParam{} = noTH "toCxt" a- toPred p = todo "toPred" p--#if MIN_VERSION_template_haskell(2,11,0)-instance ToCxt (Hs.Deriving l) where- toCxt (Hs.Deriving _ rule) = toCxt rule-instance ToCxt [Hs.InstRule l] where- toCxt = concatMap toCxt-#endif--instance ToCxt a => ToCxt (Maybe a) where- toCxt Nothing = []- toCxt (Just a) = toCxt a--foldAppT :: Type -> [Type] -> Type-foldAppT t ts = foldl' AppT t ts----------------------------------------------------------------------------------- * ToStmt HsStmt--instance ToStmt (Hs.Stmt l) where- toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e)- toStmt (Hs.Qualifier _ e) = NoBindS (toExp e)- toStmt a@(Hs.LetStmt _ bnds) = LetS (toDecs bnds)- toStmt s@Hs.RecStmt{} = noTH "toStmt" s------------------------------------------------------------------------------------ * ToDec HsDecl--instance ToDec (Hs.Decl l) where- toDec (Hs.TypeDecl _ h t)- = TySynD (toName h) (toTyVars h) (toType t)-- toDec a@(Hs.DataDecl _ dOrN cxt h qcds qns)- = case dOrN of- Hs.DataType _ -> DataD (toCxt cxt)- (toName h)- (toTyVars h)-#if MIN_VERSION_template_haskell(2,11,0)- Nothing-#endif- (fmap qualConDeclToCon qcds)-#if MIN_VERSION_template_haskell(2,11,0)- -- Convert a Deriving into a list of types, one for each derived class- -- Assumes that the types do not have any contexts- (maybe [] (\(Hs.Deriving _ q) -> map toType q) qns)-#else- (toNames qns)-#endif- Hs.NewType _ -> let qcd = case qcds of- [x] -> x- _ -> nonsense "toDec" ("newtype with " ++- "wrong number of constructors") a- in NewtypeD (toCxt cxt)- (toName h)- (toTyVars h)-#if MIN_VERSION_template_haskell(2,11,0)- Nothing-#endif- (qualConDeclToCon qcd)-#if MIN_VERSION_template_haskell(2,11,0)- (maybe [] (\(Hs.Deriving _ q) -> map toType q) qns)-#else- (toNames qns)-#endif-- -- 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!"-- toDec (Hs.InlineConlikeSig _ act qn) = PragmaD $- InlineP (toName qn) Inline ConLike (transAct act)- toDec (Hs.InlineSig _ b act qn) = PragmaD $- InlineP (toName qn) inline FunLike (transAct act)- where- inline | b = Inline | otherwise = NoInline--#if MIN_VERSION_template_haskell(2,11,0)-#if MIN_VERSION_haskell_src_exts(1,18,0)- toDec (Hs.TypeFamDecl _ h sig inj)- = OpenTypeFamilyD $ TypeFamilyHead (toName h)- (toTyVars h)- (maybe NoSig KindSig . toMaybeKind $ sig)- (fmap toInjectivityAnn inj)- toDec (Hs.DataFamDecl _ _ h sig)- = DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig)-#else- toDec (Hs.TypeFamDecl _ h k)- = OpenTypeFamilyD $ TypeFamilyHead (toName h)- (toTyVars h)- (maybe NoSig (KindSig . toKind) k)- Nothing- -- TODO: do something with context?- toDec (Hs.DataFamDecl _ _ h k)- = DataFamilyD (toName h) (toTyVars h) (fmap toKind k)-#endif--#else-#if MIN_VERSION_haskell_src_exts(1,18,0)- toDec (Hs.TypeFamDecl _ h sig inj)- = FamilyD TypeFam (toName h) (toTyVars h) (toMaybeKind sig)- toDec (Hs.DataFamDecl _ _ h sig)- = FamilyD DataFam (toName h) (toTyVars h) (toMaybeKind sig)-#else- toDec (Hs.TypeFamDecl _ h k)- = FamilyD TypeFam (toName h) (toTyVars h) (fmap toKind k)-- -- TODO: do something with context?- toDec (Hs.DataFamDecl _ _ h k)- = FamilyD DataFam (toName h) (toTyVars h) (fmap toKind k)-#endif-#endif /* MIN_VERSION_template_haskell(2,11,0) */-- toDec a@(Hs.FunBind _ mtchs) = hsMatchesToFunD mtchs- toDec (Hs.PatBind _ p rhs bnds) = ValD (toPat p)- (hsRhsToBody rhs)- (toDecs bnds)-- toDec i@(Hs.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.-#if MIN_VERSION_template_haskell(2,11,0)- toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD- Nothing- (toCxt irule)- (toType irule)- (toDecs ids)-#else- toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD- (toCxt irule)- (toType irule)- (toDecs ids)-#endif-- toDec (Hs.ClassDecl _ cxt h fds decls) = ClassD- (toCxt cxt)- (toName h)- (toTyVars h)- (fmap toFunDep fds)- (toDecs decls)- where- toFunDep (Hs.FunDep _ ls rs) = FunDep (fmap toName ls) (fmap toName rs)-- toDec x = todo "toDec" x--#if MIN_VERSION_haskell_src_exts(1,18,0)-instance ToMaybeKind (Hs.ResultSig l) where- toMaybeKind (Hs.KindSig _ k) = Just $ toKind k- toMaybeKind (Hs.TyVarSig _ _) = Nothing--instance ToMaybeKind a => ToMaybeKind (Maybe a) where- toMaybeKind Nothing = Nothing- toMaybeKind (Just a) = toMaybeKind a--#if MIN_VERSION_template_haskell(2,11,0)-instance ToInjectivityAnn (Hs.InjectivityInfo l) where- toInjectivityAnn (Hs.InjectivityInfo _ n ns) = InjectivityAnn (toName n) (fmap toName ns)-#endif-#endif--transAct :: Maybe (Hs.Activation l) -> Phases-transAct Nothing = AllPhases-transAct (Just (Hs.ActiveFrom _ n)) = FromPhase n-transAct (Just (Hs.ActiveUntil _ n)) = BeforePhase n--instance ToName (Hs.DeclHead l) where- toName (Hs.DHead _ n) = toName n- toName (Hs.DHInfix _ _ n) = toName n- toName (Hs.DHParen _ h) = toName h- toName (Hs.DHApp _ h _) = toName h--instance ToTyVars (Hs.DeclHead l) where- toTyVars (Hs.DHead _ _) = []- toTyVars (Hs.DHParen _ h) = toTyVars h- toTyVars (Hs.DHInfix _ tvb _) = [toTyVar tvb]- toTyVars (Hs.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb]--instance ToNames a => ToNames (Maybe a) where- toNames Nothing = []- toNames (Just a) = toNames a--instance ToNames (Hs.Deriving l) where- toNames (Hs.Deriving _ irules) = concatMap toNames irules-instance ToNames (Hs.InstRule l) where- toNames (Hs.IParen _ irule) = toNames irule- toNames (Hs.IRule _ _mtvbs _mcxt mihd) = toNames mihd-instance ToNames (Hs.InstHead l) where- toNames (Hs.IHCon _ n) = [toName n]- toNames (Hs.IHInfix _ _ n) = [toName n]- toNames (Hs.IHParen _ h) = toNames h- toNames (Hs.IHApp _ h _) = toNames h--instance ToCxt (Hs.InstRule l) where- toCxt (Hs.IRule _ _ cxt _) = toCxt cxt- toCxt (Hs.IParen _ irule) = toCxt irule--instance ToCxt (Hs.Context l) where- toCxt x = case x of- Hs.CxEmpty _ -> []- Hs.CxSingle _ x' -> [toPred x']- Hs.CxTuple _ xs -> fmap toPred xs--instance ToType (Hs.InstRule l) where- toType (Hs.IRule _ _ _ h) = toType h- toType (Hs.IParen _ irule) = toType irule--instance ToType (Hs.InstHead l) where- toType (Hs.IHCon _ qn) = toType qn- toType (Hs.IHInfix _ typ qn) = AppT (toType typ) (toType qn)- toType (Hs.IHParen _ hd) = toType hd- toType (Hs.IHApp _ hd typ) = AppT (toType hd) (toType typ)--qualConDeclToCon :: Hs.QualConDecl l -> Con-qualConDeclToCon (Hs.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl-qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (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 (Hs.TyVarBind l) where- toTyVars tvb = [toTyVar tvb]--instance ToType (Hs.QName l) where- toType = ConT . toName--conDeclToCon :: Hs.ConDecl l -> Con-conDeclToCon (Hs.ConDecl _ n tys)- = NormalC (toName n) (map toStrictType tys)-conDeclToCon (Hs.RecDecl _ n fieldDecls)- = RecC (toName n) (concatMap convField fieldDecls)- where- convField :: Hs.FieldDecl l -> [VarStrictType]- convField (Hs.FieldDecl _ ns t) =- let (strict, ty) = toStrictType t- in map (\n' -> (toName n', strict, ty)) ns---hsMatchesToFunD :: [Hs.Match l] -> Dec-hsMatchesToFunD [] = FunD (mkName []) [] -- errorish-hsMatchesToFunD xs@(Hs.Match _ n _ _ _ : _) = FunD (toName n) (fmap hsMatchToClause xs)---hsMatchToClause :: Hs.Match l -> Clause-hsMatchToClause (Hs.Match _ _ ps rhs bnds) = Clause- (fmap toPat ps)- (hsRhsToBody rhs)- (toDecs bnds)----hsRhsToBody :: Hs.Rhs l -> 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 l -> 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 l -> 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 (toDecs bs)]------------------------------------------------------------------------------------ * ToDecs InstDecl-instance ToDecs (Hs.InstDecl l) where- toDecs (Hs.InsDecl _ decl) = toDecs decl- toDecs d = todo "toDec" d---- * ToDecs HsDecl HsBinds--instance ToDecs (Hs.Decl l) where- toDecs a@(Hs.TypeSig _ ns t)- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns- in xs-- toDecs (Hs.InfixDecl l assoc Nothing ops) =- toDecs (Hs.InfixDecl l assoc (Just 9) ops)- toDecs (Hs.InfixDecl _ assoc (Just fixity) ops) =- map (\op -> InfixD (Fixity fixity dir) (toName op)) ops- where- dir = case assoc of- Hs.AssocNone _ -> InfixN- Hs.AssocLeft _ -> InfixL- Hs.AssocRight _ -> InfixR-- toDecs a = [toDec a]--collectVars e = case e of- VarT n -> [PlainTV n]- 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-------------------------------------------------------------------------------+{-# 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.List (findIndex)-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.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 @@ -63,15 +111,6 @@ instance Show (Q String) where show = unsafeRunQ instance Show (Q Doc) where show = show . unsafeRunQ -#if !MIN_VERSION_th_orphans(0,12,0)-#if MIN_VERSION_base(4,7,0)-deriving instance Typeable Q-#else-deriving instance Typeable1 Q-#endif-deriving instance Typeable QuasiQuoter-#endif- -- | @unsafeRunQ = unsafePerformIO . runQ@ unsafeRunQ :: Q a -> a unsafeRunQ = unsafePerformIO . runQ@@ -81,18 +120,18 @@ 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])) -----------------------------------------------------------------------------@@ -114,7 +153,7 @@ unForall :: Type -> Type unForall (ForallT _ _ t) = t-unForall t = t+unForall t = t functionT :: [TypeQ] -> TypeQ functionT = foldl1 (|->|)@@ -130,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@@ -146,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)@@ -164,21 +205,11 @@ (t',env4,new4) = renameT env3 new3 t in (ForallT ns'' cxt' t', env4, new4) where- unVarT (VarT n) = PlainTV n+ unVarT (VarT n) = Compat.plainTV n+ unVarT ty = error $ "renameT: unVarT: TODO for" ++ show ty renamePreds = renameThings renamePred--#if MIN_VERSION_template_haskell(2,10,0) renamePred = renameT-#else- 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)-#endif+renameT _ _ t = error $ "renameT: TODO for " ++ show t -- | Remove qualification, etc. normaliseName :: Name -> Name@@ -221,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@@ -228,63 +263,19 @@ -decCons :: Dec -> [Con]-#if MIN_VERSION_template_haskell(2,11,0)-decCons (DataD _ _ _ _ cons _) = cons-decCons (NewtypeD _ _ _ _ con _) = [con]-#else-decCons (DataD _ _ _ cons _) = cons-decCons (NewtypeD _ _ _ con _) = [con]-#endif-decCons _ = [] --decTyVars :: Dec -> [TyVarBndr]-#if MIN_VERSION_template_haskell(2,11,0)-decTyVars (DataD _ _ ns _ _ _) = ns-decTyVars (NewtypeD _ _ ns _ _ _) = ns-#else-decTyVars (DataD _ _ ns _ _) = ns-decTyVars (NewtypeD _ _ ns _ _) = ns-#endif-decTyVars (TySynD _ ns _) = ns-decTyVars (ClassD _ _ ns _ _) = ns-decTyVars _ = []---decName :: Dec -> Maybe Name-decName (FunD n _) = Just n-#if MIN_VERSION_template_haskell(2,11,0)-decName (DataD _ n _ _ _ _) = Just n-decName (NewtypeD _ n _ _ _ _) = Just n-#else-decName (DataD _ n _ _ _) = Just n-decName (NewtypeD _ n _ _ _) = Just n-#endif-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.@@ -308,42 +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]-#if MIN_VERSION_template_haskell(2,11,0)-dataDCons (DataD _ _ _ _ cons _) = cons-#else-dataDCons (DataD _ _ _ cons _) = cons-#endif-dataDCons _ = []+recCName _ = Nothing fromDataConI :: Info -> Q (Maybe Exp)-#if MIN_VERSION_template_haskell(2,11,0)-fromDataConI (DataConI dConN ty tyConN) =-#else-fromDataConI (DataConI dConN ty tyConN fxty) =-#endif+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) []]
− src/Language/Haskell/TH/Instances/Lift.hs
@@ -1,16 +0,0 @@-{- |- 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)-- This module is exported for backwards-compatibility purposes.- All it does is re-export the instances defined in- "Language.Haskell.TH.Instances", from the th-orphans package.--}-module Language.Haskell.TH.Instances.Lift- {-# DEPRECATED "Use the th-orphans package instead." #-} () where--import Language.Haskell.TH.Instances
+ 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