haskell-src-meta 0.6.0.14 → 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/−33
- src/Language/Haskell/Meta.hs +3/−2
- src/Language/Haskell/Meta/Extensions.hs +407/−0
- src/Language/Haskell/Meta/Parse.hs +47/−41
- src/Language/Haskell/Meta/Parse/Careful.hs +0/−60
- src/Language/Haskell/Meta/Syntax/Translate.hs +828/−645
- 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,56 +1,88 @@ name: haskell-src-meta-version: 0.6.0.14-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.4.2, 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,+ 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-- -- haskell-src-exts 1.17 is not compatible with versions of GHC prior to 7.8,- -- but we still maintain compatibility back to GHC 7.4.- if impl(ghc >= 7.8)- build-depends:- haskell-src-exts >= 1.16 && < 1.18- else - build-depends:- haskell-src-exts == 1.16.*+ 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
@@ -1,4 +1,3 @@- {- | Module : Language.Haskell.Meta Copyright : (c) Matt Morrow 2008@@ -9,10 +8,12 @@ -} module Language.Haskell.Meta (+ module Language.Haskell.Meta.Extensions, module Language.Haskell.Meta.Parse, module Language.Haskell.Meta.Syntax.Translate ) where +import Language.Haskell.Meta.Extensions import Language.Haskell.Meta.Parse import Language.Haskell.Meta.Syntax.Translate-import Language.Haskell.TH.Instances()+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,63 +13,61 @@ parseExp, parseType, parseDecs,+ parseDecsWithMode, myDefaultParseMode, myDefaultExtensions, parseResultToEither, parseHsModule, parseHsDecls,+ parseHsDeclsWithMode, parseHsType, parseHsExp, parseHsPat, pprHsModule, moduleDecls,- emptySrcLoc,+ noSrcSpanInfo, 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-import qualified Language.Haskell.Exts.Syntax as Hs-import Language.Haskell.Exts.Annotated.Fixity as Fix-import Language.Haskell.Exts.Extension-import Language.Haskell.Exts.Parser hiding (parseExp, parseType, parsePat)-import Language.Haskell.Exts.Pretty+import Language.Haskell.Exts.Extension+import Language.Haskell.Exts.Parser hiding+ (parseExp, parsePat, parseType)+import Language.Haskell.Exts.Pretty+import qualified Language.Haskell.Exts.SrcLoc as Hs+import qualified Language.Haskell.Exts.Syntax as Hs+import Language.Haskell.Meta.Syntax.Translate+import Language.Haskell.TH.Syntax hiding (Extension (..)) ----------------------------------------------------------------------------- -- * template-haskell parsePat :: String -> Either String Pat-parsePat = either Left (Right . toPat) . parseHsPat+parsePat = fmap toPat . parseHsPat parseExp :: String -> Either String Exp-parseExp = either Left (Right . toExp) . parseHsExp+parseExp = fmap toExp . parseHsExp parseType :: String -> Either String Type-parseType = either Left (Right . toType) . parseHsType+parseType = fmap toType . parseHsType parseDecs :: String -> Either String [Dec]-parseDecs = either Left (Right . toDecs) . parseHsDecls+parseDecs = fmap toDecs . parseHsDecls +-- | @since 0.8.2+parseDecsWithMode :: ParseMode -> String -> Either String [Dec]+parseDecsWithMode parseMode = fmap toDecs+ . parseHsDeclsWithMode parseMode+ ----------------------------------------------------------------------------- {-# DEPRECATED myDefaultParseMode, myDefaultExtensions "The provided ParseModes aren't very meaningful, use your own instead" #-} myDefaultParseMode :: ParseMode-myDefaultParseMode = ParseMode+myDefaultParseMode = defaultParseMode {parseFilename = [] ,baseLanguage = Haskell2010 ,extensions = map EnableExtension myDefaultExtensions- ,ignoreLinePragmas = False- ,ignoreLanguagePragmas = False- ,fixities = Nothing-#if MIN_VERSION_haskell_src_exts(1,17,0)- ,ignoreFunctionArity = False-#endif } myDefaultExtensions :: [KnownExtension]@@ -82,7 +80,8 @@ ,TemplateHaskell ,RankNTypes ,MultiParamTypeClasses- ,RecursiveDo]+ ,RecursiveDo+ ,TypeApplications] parseResultToEither :: ParseResult a -> Either String a parseResultToEither (ParseOk a) = Right a@@ -90,47 +89,54 @@ = let line = Hs.srcLine loc - 1 in Left (unlines [show line,show loc,e]) -parseHsModule :: String -> Either String Hs.Module+parseHsModule :: String -> Either String (Hs.Module Hs.SrcSpanInfo) parseHsModule = parseResultToEither . parseModuleWithMode myDefaultParseMode -parseHsDecls :: String -> Either String [Hs.Decl]-parseHsDecls = either Left (Right . moduleDecls)+parseHsDecls :: String -> Either String [Hs.Decl Hs.SrcSpanInfo]+parseHsDecls = fmap moduleDecls . parseResultToEither . parseModuleWithMode myDefaultParseMode +-- | @since 0.8.2+parseHsDeclsWithMode :: ParseMode -> String -> Either String [Hs.Decl Hs.SrcSpanInfo]+parseHsDeclsWithMode parseMode = fmap moduleDecls+ . parseResultToEither . parseModuleWithMode parseMode -parseHsType :: String -> Either String Hs.Type++parseHsType :: String -> Either String (Hs.Type Hs.SrcSpanInfo) parseHsType = parseResultToEither . parseTypeWithMode myDefaultParseMode -parseHsExp :: String -> Either String Hs.Exp+parseHsExp :: String -> Either String (Hs.Exp Hs.SrcSpanInfo) parseHsExp = parseResultToEither . parseExpWithMode myDefaultParseMode -parseHsPat :: String -> Either String Hs.Pat+parseHsPat :: String -> Either String (Hs.Pat Hs.SrcSpanInfo) parseHsPat = parseResultToEither . parsePatWithMode myDefaultParseMode -pprHsModule :: Hs.Module -> String+pprHsModule :: Hs.Module Hs.SrcSpanInfo -> String pprHsModule = prettyPrint -moduleDecls :: Hs.Module -> [Hs.Decl]-moduleDecls (Hs.Module _ _ _ _ _ _ x) = x+moduleDecls :: Hs.Module Hs.SrcSpanInfo -> [Hs.Decl Hs.SrcSpanInfo]+moduleDecls (Hs.Module _ _ _ _ x) = x+moduleDecls m = todo "" m+-- TODO+-- (Hs.XmlPage _ _ _ _ _ _ _)+-- (Hs.XmlHybrid _ _ _ _ _ _ _ _ _) -- mkModule :: String -> Hs.Module -- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] [] -emptySrcLoc :: Hs.SrcLoc-emptySrcLoc = (Hs.SrcLoc [] 0 0)--emptyHsModule :: String -> Hs.Module+emptyHsModule :: String -> Hs.Module Hs.SrcSpanInfo emptyHsModule n = (Hs.Module- emptySrcLoc- (Hs.ModuleName n)+ noSrcSpanInfo+ (Just (Hs.ModuleHead noSrcSpanInfo (Hs.ModuleName noSrcSpanInfo n) Nothing Nothing)) []- Nothing- Nothing [] [])++noSrcSpanInfo :: Hs.SrcSpanInfo+noSrcSpanInfo = Hs.noInfoSpan (Hs.mkSrcSpan Hs.noLoc Hs.noLoc) {- ghci> :i Module
− src/Language/Haskell/Meta/Parse/Careful.hs
@@ -1,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,645 +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.Syntax as Hs----------------------------------------------------------------------------------class ToName a where toName :: a -> Name-class ToLit a where toLit :: a -> Lit-class ToType a where toType :: a -> Type-class ToPat a where toPat :: a -> Pat-class ToExp a where toExp :: a -> Exp-class ToDecs a where toDecs :: a -> [Dec]-class ToDec a where toDec :: a -> Dec-class ToStmt a where toStmt :: a -> Stmt-class ToLoc a where toLoc :: a -> Loc-class ToCxt a where toCxt :: a -> Cxt---- for error messages-moduleName = "Language.Haskell.Meta.Syntax.Translate"---- When to use each of these isn't always clear: prefer 'todo' if unsure.-noTH :: Show e => String -> e -> a-noTH fun thing = error . concat $ [moduleName, ".", fun,- ": template-haskell has no representation for: ", show thing]--noTHyet :: Show e => String -> String -> e -> a-noTHyet fun minVersion thing = error . concat $ [moduleName, ".", fun,- ": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")",- " has no representation for: ", show thing]--todo :: Show e => String -> e -> a-todo fun thing = error . concat $ [moduleName, ".", fun,- ": not implemented: ", show thing]--nonsense :: Show e => String -> String -> e -> a-nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun,- ": nonsensical: ", inparticular, ": ", show thing]----------------------------------------------------------------------------------instance ToExp Lit where- toExp = LitE-instance (ToExp a) => ToExp [a] where- toExp = ListE . fmap toExp-instance (ToExp a, ToExp b) => ToExp (a,b) where- toExp (a,b) = TupE [toExp a, toExp b]-instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where- toExp (a,b,c) = TupE [toExp a, toExp b, toExp c]-instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where- toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d]---instance ToPat Lit where- toPat = LitP-instance (ToPat a) => ToPat [a] where- toPat = ListP . fmap toPat-instance (ToPat a, ToPat b) => ToPat (a,b) where- toPat (a,b) = TupP [toPat a, toPat b]-instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where- toPat (a,b,c) = TupP [toPat a, toPat b, toPat c]-instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where- toPat (a,b,c,d) = TupP [toPat a, toPat b, toPat c, toPat d]---instance ToLit Char where- toLit = CharL-instance ToLit String where- toLit = StringL-instance ToLit Integer where- toLit = IntegerL-instance ToLit Int where- toLit = IntegerL . toInteger-instance ToLit Float where- toLit = RationalL . toRational-instance ToLit Double where- toLit = RationalL . toRational------------------------------------------------------------------------------------- * ToName {String,HsName,Module,HsSpecialCon,HsQName}---instance ToName String where- toName = mkName--instance ToName Hs.Name where- toName (Hs.Ident s) = toName s- toName (Hs.Symbol s) = toName s--instance ToName Hs.Module where- toName (Hs.Module _ (Hs.ModuleName s) _ _ _ _ _) = toName s---instance ToName Hs.SpecialCon where- toName Hs.UnitCon = '()- toName Hs.ListCon = '[]- toName Hs.FunCon = ''(->)- toName (Hs.TupleCon _ n)- | n<2 = '()- | otherwise =- let x = maybe [] (++".") (nameModule '(,))- in mkName . concat $ x : ["(",replicate (n-1) ',',")"]- toName Hs.Cons = '(:)---instance ToName Hs.QName where--- toName (Hs.Qual (Hs.Module []) n) = toName n- toName (Hs.Qual (Hs.ModuleName []) n) = toName n- toName (Hs.Qual (Hs.ModuleName m) n) =- let m' = show . toName $ m- n' = show . toName $ n- in toName . concat $ [m',".",n']- toName (Hs.UnQual n) = toName n- toName (Hs.Special s) = toName s---instance ToName Hs.Op where- toName (Hs.VarOp n) = toName n- toName (Hs.ConOp n) = toName n------------------------------------------------------------------------------------ * ToLit HsLiteral---instance ToLit Hs.Literal where- toLit (Hs.Char a) = CharL a- toLit (Hs.String a) = StringL a- toLit (Hs.Int a) = IntegerL a- toLit (Hs.Frac a) = RationalL a- toLit l@Hs.PrimChar{} = noTH "toLit" l-#if MIN_VERSION_template_haskell(2,8,0)- toLit (Hs.PrimString a) = StringPrimL (map toWord8 a)- where- toWord8 = fromIntegral . ord-#else- toLit (Hs.PrimString a) = StringPrimL a-#endif- 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 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 where- toExp (Hs.QVarOp n) = VarE (toName n)- toExp (Hs.QConOp n) = ConE (toName n)--toFieldExp :: Hs.FieldUpdate -> FieldExp-toFieldExp (Hs.FieldUpdate n e) = (toName n, toExp e)-----instance ToExp Hs.Exp where- 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)-#if MIN_VERSION_template_haskell(2,8,0)- toExp (Hs.MultiIf ifs) = MultiIfE (map toGuard ifs)-#else- toExp e@Hs.MultiIf{} = noTHyet "toExp" "2.8.0" e-#endif- 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 -> Match-toMatch (Hs.Alt _ p rhs ds) = Match (toPat p) (toBody rhs) (toDecs ds)--toBody :: Hs.Rhs -> 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------------------------------------------------------------------------------------ * ToLoc SrcLoc--instance ToLoc Hs.SrcLoc where- toLoc (Hs.SrcLoc fn l c) =- Loc fn [] [] (l,c) (-1,-1)----------------------------------------------------------------------------------- * ToType HsType--instance ToName Hs.TyVarBind where- toName (Hs.KindedVar n _) = toName n- toName (Hs.UnkindedVar n) = toName n--instance ToName Name where- toName = id--instance ToName TyVarBndr where- toName (PlainTV n) = n- toName (KindedTV n _) = n--#if MIN_VERSION_template_haskell(2,8,0)--instance ToType Hs.Kind where- toType Hs.KindStar = StarT- toType (Hs.KindFn k1 k2) = toType k1 .->. toType k2- toType (Hs.KindParen kp) = toType kp-#if !MIN_VERSION_haskell_src_exts(1,17,0)- toType k@Hs.KindBang = noTH "toKind" k-#endif - toType (Hs.KindVar n) = VarT (toName n)--toKind :: Hs.Kind -> Kind-toKind = toType--#else--toKind :: Hs.Kind -> Kind-toKind Hs.KindStar = StarK-toKind (Hs.KindFn k1 k2) = ArrowK (toKind k1) (toKind k2)-toKind (Hs.KindParen kp) = toKind kp-toKind k@Hs.KindBang = noTH "toKind" k-toKind k@Hs.KindVar{} = noTHyet "toKind" "2.8.0" k--#endif /* !MIN_VERSION_template_haskell(2,8,0) */--toTyVar :: Hs.TyVarBind -> TyVarBndr-toTyVar (Hs.KindedVar n k) = KindedTV (toName n) (toKind k)-toTyVar (Hs.UnkindedVar n) = PlainTV (toName n)--instance ToType Hs.Type where- toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t)- toType (Hs.TyFun a b) = toType a .->. toType b- toType (Hs.TyList t) = ListT `AppT` toType t- toType (Hs.TyTuple 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 -> StrictType-#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) */---(.->.) :: Type -> Type -> Type-a .->. b = AppT (AppT ArrowT a) b--instance ToCxt Hs.Context where- toCxt = fmap toPred- 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--#if MIN_VERSION_template_haskell(2,11,0)-instance ToCxt [Hs.Deriving] where- toCxt = fmap toPred- where- toPred (qn, ts) = foldl' AppT (ConT (toName qn)) (fmap toType ts)-#endif--foldAppT :: Type -> [Type] -> Type-foldAppT t ts = foldl' AppT t ts----------------------------------------------------------------------------------- * ToStmt HsStmt--instance ToStmt Hs.Stmt where- toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e)- toStmt (Hs.Qualifier e) = NoBindS (toExp e)- toStmt a@(Hs.LetStmt bnds) = LetS (toDecs bnds)- toStmt s@Hs.RecStmt{} = noTH "toStmt" s------------------------------------------------------------------------------------ * ToDec HsDecl--instance ToDec Hs.Decl where- toDec (Hs.TypeDecl _ n ns t)- = TySynD (toName n) (fmap toTyVar ns) (toType t)-- toDec a@(Hs.DataDecl _ dOrN cxt n ns qcds qns)- = case dOrN of- Hs.DataType -> DataD (toCxt cxt)- (toName n)- (fmap toTyVar ns)-#if MIN_VERSION_template_haskell(2,11,0)- Nothing-#endif- (fmap qualConDeclToCon qcds)-#if MIN_VERSION_template_haskell(2,11,0)- (toCxt qns)-#else- (fmap (toName . fst) 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 n)- (fmap toTyVar ns)-#if MIN_VERSION_template_haskell(2,11,0)- Nothing-#endif- (qualConDeclToCon qcd)-#if MIN_VERSION_template_haskell(2,11,0)- (toCxt qns)-#else- (fmap (toName . fst) 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!"--#if MIN_VERSION_template_haskell(2,8,0)-- 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--#else-- toDec (Hs.InlineConlikeSig _ act id) = PragmaD $ - InlineP (toName id) (InlineSpec True True $ transAct act)- toDec (Hs.InlineSig _ b act id) = PragmaD $ - InlineP (toName id) (InlineSpec b False $ transAct act)--#endif /* MIN_VERSION_template_haskell(2,8,0) */--#if MIN_VERSION_template_haskell(2,11,0)- toDec (Hs.TypeFamDecl _ n ns k)- = OpenTypeFamilyD $ TypeFamilyHead (toName n)- (fmap toTyVar ns)- (maybe NoSig (KindSig . toKind) k)- Nothing-- -- TODO: do something with context?- toDec (Hs.DataFamDecl _ _ n ns k)- = DataFamilyD (toName n) (fmap toTyVar ns) (fmap toKind k)-#else- toDec (Hs.TypeFamDecl _ n ns k)- = FamilyD TypeFam (toName n) (fmap toTyVar ns) (fmap toKind k)-- -- TODO: do something with context?- toDec (Hs.DataFamDecl _ _ n ns k)- = FamilyD DataFam (toName n) (fmap toTyVar ns) (fmap toKind k)-#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" (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 _vars cxt qname ts ids) = InstanceD - Nothing- (toCxt cxt) - (foldl AppT (ConT (toName qname)) (map toType ts))- (toDecs ids)-#else- toDec (Hs.InstDecl _ Nothing _vars cxt qname ts ids) = InstanceD - (toCxt cxt) - (foldl AppT (ConT (toName qname)) (map toType ts))- (toDecs ids)-#endif-- toDec (Hs.ClassDecl _ cxt name ts fds decls) = ClassD- (toCxt cxt)- (toName name)- (fmap toTyVar ts)- (fmap toFunDep fds)- (fmap classDeclToDec decls)- where- classDeclToDec cd = case cd of- (Hs.ClsDecl d) -> toDec d- x -> todo "classDecl" x- toFunDep (Hs.FunDep ls rs) = FunDep (fmap toName ls) (fmap toName rs)-- toDec x = todo "toDec" x--#if MIN_VERSION_template_haskell(2,8,0)-transAct :: Hs.Activation -> Phases-transAct Hs.AlwaysActive = AllPhases-transAct (Hs.ActiveFrom n) = FromPhase n-transAct (Hs.ActiveUntil n) = BeforePhase n-#else-transAct act = case act of- Hs.AlwaysActive -> Nothing- Hs.ActiveFrom n -> Just (True,n)- Hs.ActiveUntil n -> Just (False,n)-#endif---qualConDeclToCon :: Hs.QualConDecl -> Con-qualConDeclToCon (Hs.QualConDecl _ [] [] cdecl) = conDeclToCon cdecl-qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toTyVar ns)- (toCxt cxt)- (conDeclToCon cdecl)-conDeclToCon :: Hs.ConDecl -> Con-conDeclToCon (Hs.ConDecl n tys)- = NormalC (toName n) (map toStrictType tys)-conDeclToCon (Hs.RecDecl n fieldDecls)- = RecC (toName n) (concatMap convField fieldDecls)- where- convField (fields, t) =- let (strict, ty) = toStrictType t- in map (\field -> (toName field, strict, ty)) fields---hsMatchesToFunD :: [Hs.Match] -> Dec-hsMatchesToFunD [] = FunD (mkName []) [] -- errorish-hsMatchesToFunD xs@(Hs.Match _ n _ _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)---hsMatchToClause :: Hs.Match -> Clause-hsMatchToClause (Hs.Match _ _ ps _ rhs bnds) = Clause- (fmap toPat ps)- (hsRhsToBody rhs)- (toDecs bnds)----hsRhsToBody :: Hs.Rhs -> Body-hsRhsToBody (Hs.UnGuardedRhs e) = NormalB (toExp e)-hsRhsToBody (Hs.GuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a- in GuardedB . concat- . fmap (fromGuardedB . hsGuardedRhsToBody)- $ hsgrhs----hsGuardedRhsToBody :: Hs.GuardedRhs -> Body-hsGuardedRhsToBody (Hs.GuardedRhs _ [] e) = NormalB (toExp e)-hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]-hsGuardedRhsToBody (Hs.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss- (pgs,ngs) = unzip [(p,n)- | (PatG p) <- ss'- , n@(NormalG _) <- ss']- e' = toExp e- patg = PatG (concat pgs)- in GuardedB $ (patg,e') : zip ngs (repeat e')----hsStmtToGuard :: Hs.Stmt -> Guard-hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)]-hsStmtToGuard (Hs.Qualifier e) = NormalG (toExp e)-hsStmtToGuard (Hs.LetStmt bs) = PatG [LetS (toDecs bs)]------------------------------------------------------------------------------------ * ToDecs InstDecl-instance ToDecs Hs.InstDecl where- toDecs (Hs.InsDecl decl) = toDecs decl- toDecs d = todo "toDec" d---- * ToDecs HsDecl HsBinds--instance ToDecs Hs.Decl where- toDecs a@(Hs.TypeSig _ ns t)- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns- in xs--#if MIN_VERSION_template_haskell(2,8,0)- toDecs (Hs.InfixDecl _ assoc 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-#endif-- 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--instance ToDecs Hs.Binds where- toDecs (Hs.BDecls ds) = toDecs ds- toDecs a@(Hs.IPBinds {}) = noTH "ToDecs Hs.Binds" a--instance ToDecs (Maybe Hs.Binds) where- toDecs Nothing = []- toDecs (Just (Hs.BDecls ds)) = toDecs ds--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++{- |+ Module : Language.Haskell.Meta.Syntax.Translate+ Copyright : (c) Matt Morrow 2008+ License : BSD3+ Maintainer : Matt Morrow <mjm2002@gmail.com>+ Stability : experimental+ Portability : portable (template-haskell)+-}++module Language.Haskell.Meta.Syntax.Translate (+ module Language.Haskell.Meta.Syntax.Translate+ , TyVarBndr_+) where++import qualified Data.Char as Char+import qualified Data.List as List+import qualified Language.Haskell.Exts.SrcLoc as Exts.SrcLoc+import qualified Language.Haskell.Exts.Syntax as Exts+import Language.Haskell.Meta.THCompat (TyVarBndr_)+import qualified Language.Haskell.Meta.THCompat as Compat+import qualified Language.Haskell.TH.Lib as TH+import qualified Language.Haskell.TH.Syntax as TH++-----------------------------------------------------------------------------++class ToName a where toName :: a -> TH.Name+class ToNames a where toNames :: a -> [TH.Name]+class ToLit a where toLit :: a -> TH.Lit+class ToType a where toType :: a -> TH.Type+class ToPat a where toPat :: a -> TH.Pat+class ToExp a where toExp :: a -> TH.Exp+class ToDecs a where toDecs :: a -> [TH.Dec]+class ToDec a where toDec :: a -> TH.Dec+class ToStmt a where toStmt :: a -> TH.Stmt+class ToLoc a where toLoc :: a -> TH.Loc+class ToCxt a where toCxt :: a -> TH.Cxt+class ToPred a where toPred :: a -> TH.Pred+class ToTyVars a where toTyVars :: a -> [TyVarBndr_ ()]+class ToMaybeKind a where toMaybeKind :: a -> Maybe TH.Kind+class ToInjectivityAnn a where toInjectivityAnn :: a -> TH.InjectivityAnn++type DerivClause = TH.DerivClause++class ToDerivClauses a where toDerivClauses :: a -> [DerivClause]++-- for error messages+moduleName :: String+moduleName = "Language.Haskell.Meta.Syntax.Translate"++-- When to use each of these isn't always clear: prefer 'todo' if unsure.+noTH :: (Functor f, Show (f ())) => String -> f e -> a+noTH fun thing = error . concat $ [moduleName, ".", fun,+ ": template-haskell has no representation for: ", show (fmap (const ()) thing)]++noTHyet :: (Functor f, Show (f ())) => String -> String -> f e -> a+noTHyet fun minVersion thing = error . concat $ [moduleName, ".", fun,+ ": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")",+ " has no representation for: ", show (fmap (const ()) thing)]++todo :: (Functor f, Show (f ())) => String -> f e -> a+todo fun thing = error . concat $ [moduleName, ".", fun,+ ": not implemented: ", show (fmap (const ()) thing)]++nonsense :: (Functor f, Show (f ())) => String -> String -> f e -> a+nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun,+ ": nonsensical: ", inparticular, ": ", show (fmap (const ()) thing)]++#if MIN_VERSION_template_haskell(2,16,0)+toTupEl :: ToExp a => a -> Maybe TH.Exp+toTupEl = Just . toExp+#else+toTupEl :: ToExp a => a -> TH.Exp+toTupEl = toExp+#endif++-----------------------------------------------------------------------------+++instance ToExp TH.Lit where+ toExp = TH.LitE+instance (ToExp a) => ToExp [a] where+ toExp = TH.ListE . fmap toExp+instance (ToExp a, ToExp b) => ToExp (a,b) where+ toExp (a,b) = TH.TupE [toTupEl a, toTupEl b]+instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where+ toExp (a,b,c) = TH.TupE [toTupEl a, toTupEl b, toTupEl c]+instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where+ toExp (a,b,c,d) = TH.TupE [toTupEl a, toTupEl b, toTupEl c, toTupEl d]+++instance ToPat TH.Lit where+ toPat = TH.LitP+instance (ToPat a) => ToPat [a] where+ toPat = TH.ListP . fmap toPat+instance (ToPat a, ToPat b) => ToPat (a,b) where+ toPat (a,b) = TH.TupP [toPat a, toPat b]+instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where+ toPat (a,b,c) = TH.TupP [toPat a, toPat b, toPat c]+instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where+ toPat (a,b,c,d) = TH.TupP [toPat a, toPat b, toPat c, toPat d]+++instance ToLit Char where+ toLit = TH.CharL+instance ToLit String where+ toLit = TH.StringL+instance ToLit Integer where+ toLit = TH.IntegerL+instance ToLit Int where+ toLit = TH.IntegerL . toInteger+instance ToLit Float where+ toLit = TH.RationalL . toRational+instance ToLit Double where+ toLit = TH.RationalL . toRational+++-----------------------------------------------------------------------------+++-- * ToName {String,HsName,Module,HsSpecialCon,HsQName}+++instance ToName String where+ toName = TH.mkName++instance ToName (Exts.Name l) where+ toName (Exts.Ident _ s) = toName s+ toName (Exts.Symbol _ s) = toName s++instance ToName (Exts.SpecialCon l) where+ toName (Exts.UnitCon _) = TH.mkName "()" -- TODO LumiGuide: '()+ toName (Exts.ListCon _) = ''[] -- Parser only uses this in types -- TODO LumiGuide: '[]+ toName (Exts.FunCon _) = ''(->)+ toName (Exts.TupleCon _ _ n) =+ TH.mkName $ concat ["(",replicate (n-1) ',',")"]+ -- TODO LumiGuide:+ -- .+ -- .| n<2 = '()+ -- .| otherwise =+ -- . let x = maybe [] (++".") (nameModule '(,))+ -- . in TH.mkName . concat $ x : ["(",replicate (n-1) ',',")"]+ toName (Exts.Cons _) = '(:)+ toName h = todo "toName not implemented" h+ -- TODO+ -- toName (Exts.UnboxedSingleCon _) = ''+ -- toName (Exts.ExprHole _) = ''_+++instance ToName (Exts.QName l) where+-- TODO: why is this commented out?+-- toName (Exts.Qual (Exts.Module []) n) = toName n+ toName (Exts.Qual _ (Exts.ModuleName _ []) n) = toName n+ toName (Exts.Qual _ (Exts.ModuleName _ m) n) =+ let m' = show . toName $ m+ n' = show . toName $ n+ in toName . concat $ [m',".",n']+ toName (Exts.UnQual _ n) = toName n+ toName (Exts.Special _ s) = toName s++#if MIN_VERSION_haskell_src_exts(1,20,1)+instance ToName (Exts.MaybePromotedName l) where+ toName (Exts.PromotedName _ qn) = toName qn+ toName (Exts.UnpromotedName _ qn) = toName qn+#endif++instance ToName (Exts.Op l) where+ toName (Exts.VarOp _ n) = toName n+ toName (Exts.ConOp _ n) = toName n+++-----------------------------------------------------------------------------++-- * ToLit HsLiteral+++instance ToLit (Exts.Literal l) where+ toLit (Exts.Char _ a _) = TH.CharL a+ toLit (Exts.String _ a _) = TH.StringL a+ toLit (Exts.Int _ a _) = TH.IntegerL a+ toLit (Exts.Frac _ a _) = TH.RationalL a+ toLit l@Exts.PrimChar{} = noTH "toLit" l+ toLit (Exts.PrimString _ a _) = TH.StringPrimL (map toWord8 a)+ where+ toWord8 = fromIntegral . Char.ord+ toLit (Exts.PrimInt _ a _) = TH.IntPrimL a+ toLit (Exts.PrimFloat _ a _) = TH.FloatPrimL a+ toLit (Exts.PrimDouble _ a _) = TH.DoublePrimL a+ toLit (Exts.PrimWord _ a _) = TH.WordPrimL a+++-----------------------------------------------------------------------------++-- * ToPat HsPat++instance ToPat (Exts.Pat l) where+ toPat (Exts.PVar _ n)+ = TH.VarP (toName n)+ toPat (Exts.PLit _ (Exts.Signless _) l)+ = TH.LitP (toLit l)+ toPat (Exts.PLit _ (Exts.Negative _) l) = TH.LitP $ case toLit l of+ TH.IntegerL z -> TH.IntegerL (negate z)+ TH.RationalL q -> TH.RationalL (negate q)+ TH.IntPrimL z' -> TH.IntPrimL (negate z')+ TH.FloatPrimL r' -> TH.FloatPrimL (negate r')+ TH.DoublePrimL r'' -> TH.DoublePrimL (negate r'')+ _ -> nonsense "toPat" "negating wrong kind of literal" l+ toPat (Exts.PInfixApp _ p n q) = TH.UInfixP (toPat p) (toName n) (toPat q)+ toPat (Exts.PApp _ n ps) = Compat.conP (toName n) (fmap toPat ps)+ toPat (Exts.PTuple _ Exts.Boxed ps) = TH.TupP (fmap toPat ps)+ toPat (Exts.PTuple _ Exts.Unboxed ps) = TH.UnboxedTupP (fmap toPat ps)+ toPat (Exts.PList _ ps) = TH.ListP (fmap toPat ps)+ toPat (Exts.PParen _ p) = TH.ParensP (toPat p)+ -- TODO: move toFieldPat to top level defn+ toPat (Exts.PRec _ n pfs) = let toFieldPat (Exts.PFieldPat _ n' p) = (toName n', toPat p)+ toFieldPat h = todo "toFieldPat" h+ in TH.RecP (toName n) (fmap toFieldPat pfs)+ toPat (Exts.PAsPat _ n p) = TH.AsP (toName n) (toPat p)+ toPat (Exts.PWildCard _) = TH.WildP+ toPat (Exts.PIrrPat _ p) = TH.TildeP (toPat p)+ toPat (Exts.PatTypeSig _ p t) = TH.SigP (toPat p) (toType t)+ toPat (Exts.PViewPat _ e p) = TH.ViewP (toExp e) (toPat p)+ -- regular pattern+ toPat p@Exts.PRPat{} = noTH "toPat" p+ -- XML stuff+ toPat p@Exts.PXTag{} = noTH "toPat" p+ toPat p@Exts.PXETag{} = noTH "toPat" p+ toPat p@Exts.PXPcdata{} = noTH "toPat" p+ toPat p@Exts.PXPatTag{} = noTH "toPat" p+ toPat (Exts.PBangPat _ p) = TH.BangP (toPat p)+ toPat p = todo "toPat" p+ -- TODO+ -- (Exts.PNPlusK _ _ _)+ -- (Exts.PUnboxedSum _ _ _ _)+ -- (Exts.PXRPats _ _)+ -- (Exts.PSplice _ _)+ -- ...++-----------------------------------------------------------------------------++-- * ToExp HsExp++instance ToExp (Exts.QOp l) where+ toExp (Exts.QVarOp _ n) = TH.VarE (toName n)+ toExp (Exts.QConOp _ n) = TH.ConE (toName n)++toFieldExp :: Exts.FieldUpdate l -> TH.FieldExp+toFieldExp (Exts.FieldUpdate _ n e) = (toName n, toExp e)+toFieldExp h = todo "toFieldExp" h+++++instance ToExp (Exts.Exp l) where+ toExp (Exts.Var _ n) = TH.VarE (toName n)+ toExp e@Exts.IPVar{} = noTH "toExp" e+ toExp (Exts.Con _ n) = TH.ConE (toName n)+ toExp (Exts.Lit _ l) = TH.LitE (toLit l)+#if MIN_VERSION_template_haskell(2,13,0)+ toExp (Exts.OverloadedLabel _ s) = TH.LabelE s+#endif+ toExp (Exts.InfixApp _ e o f) = TH.UInfixE (toExp e) (toExp o) (toExp f)+ toExp (Exts.App _ e (Exts.TypeApp _ t)) = TH.AppTypeE (toExp e) (toType t)+ toExp (Exts.App _ e f) = TH.AppE (toExp e) (toExp f)+ toExp (Exts.NegApp _ e) = TH.AppE (TH.VarE 'negate) (toExp e)+ toExp (Exts.Lambda _ ps e) = TH.LamE (fmap toPat ps) (toExp e)+ toExp (Exts.Let _ bs e) = TH.LetE (toDecs bs) (toExp e)+ toExp (Exts.If _ a b c) = TH.CondE (toExp a) (toExp b) (toExp c)+ toExp (Exts.MultiIf _ ifs) = TH.MultiIfE (map toGuard ifs)+ toExp (Exts.Case _ e alts) = TH.CaseE (toExp e) (map toMatch alts)+#if MIN_VERSION_template_haskell(2,17,0)+ toExp (Exts.Do _ ss) = TH.DoE Nothing (map toStmt ss)+#else+ toExp (Exts.Do _ ss) = TH.DoE (map toStmt ss)+#endif+ toExp e@Exts.MDo{} = noTH "toExp" e+ toExp (Exts.Tuple _ Exts.Boxed xs) = TH.TupE (fmap toTupEl xs)+ toExp (Exts.Tuple _ Exts.Unboxed xs) = TH.UnboxedTupE (fmap toTupEl xs)+ toExp e@Exts.TupleSection{} = noTH "toExp" e+ toExp (Exts.List _ xs) = TH.ListE (fmap toExp xs)+ toExp (Exts.Paren _ e) = TH.ParensE (toExp e)+ toExp (Exts.LeftSection _ e o) = TH.InfixE (Just . toExp $ e) (toExp o) Nothing+ toExp (Exts.RightSection _ o f) = TH.InfixE Nothing (toExp o) (Just . toExp $ f)+ toExp (Exts.RecConstr _ n xs) = TH.RecConE (toName n) (fmap toFieldExp xs)+ toExp (Exts.RecUpdate _ e xs) = TH.RecUpdE (toExp e) (fmap toFieldExp xs)+ toExp (Exts.EnumFrom _ e) = TH.ArithSeqE $ TH.FromR (toExp e)+ toExp (Exts.EnumFromTo _ e f) = TH.ArithSeqE $ TH.FromToR (toExp e) (toExp f)+ toExp (Exts.EnumFromThen _ e f) = TH.ArithSeqE $ TH.FromThenR (toExp e) (toExp f)+ toExp (Exts.EnumFromThenTo _ e f g) = TH.ArithSeqE $ TH.FromThenToR (toExp e) (toExp f) (toExp g)+ toExp (Exts.ListComp _ e ss) = TH.CompE $ map convert ss ++ [TH.NoBindS (toExp e)]+ where+ convert (Exts.QualStmt _ st) = toStmt st+ convert s = noTH "toExp ListComp" s+ toExp (Exts.ExpTypeSig _ e t) = TH.SigE (toExp e) (toType t)+ toExp e = todo "toExp" e+++toMatch :: Exts.Alt l -> TH.Match+toMatch (Exts.Alt _ p rhs ds) = TH.Match (toPat p) (toBody rhs) (toDecs ds)++toBody :: Exts.Rhs l -> TH.Body+toBody (Exts.UnGuardedRhs _ e) = TH.NormalB $ toExp e+toBody (Exts.GuardedRhss _ rhss) = TH.GuardedB $ map toGuard rhss++toGuard :: Exts.GuardedRhs l -> (TH.Guard, TH.Exp)+toGuard (Exts.GuardedRhs _ stmts e) = (g, toExp e)+ where+ g = case map toStmt stmts of+ [TH.NoBindS x] -> TH.NormalG x+ xs -> TH.PatG xs++instance ToDecs a => ToDecs (Maybe a) where+ toDecs Nothing = []+ toDecs (Just a) = toDecs a++instance ToDecs (Exts.Binds l) where+ toDecs (Exts.BDecls _ ds) = toDecs ds+ toDecs a@(Exts.IPBinds {}) = noTH "ToDecs Exts.Binds" a++instance ToDecs (Exts.ClassDecl l) where+ toDecs (Exts.ClsDecl _ d) = toDecs d+ toDecs x = todo "classDecl" x++-----------------------------------------------------------------------------++-- * ToLoc SrcLoc++instance ToLoc Exts.SrcLoc.SrcLoc where+ toLoc (Exts.SrcLoc.SrcLoc fn l c) =+ TH.Loc fn [] [] (l,c) (-1,-1)++-----------------------------------------------------------------------------++-- * ToType HsType++instance ToName (Exts.TyVarBind l) where+ toName (Exts.KindedVar _ n _) = toName n+ toName (Exts.UnkindedVar _ n) = toName n++instance ToName TH.Name where+ toName = id++instance ToName (Compat.TyVarBndr_ flag) where+#if MIN_VERSION_template_haskell(2,17,0)+ toName (TH.PlainTV n _) = n+ toName (TH.KindedTV n _ _) = n+#else+ toName (TH.PlainTV n) = n+ toName (TH.KindedTV n _) = n+#endif++#if !MIN_VERSION_haskell_src_exts(1,21,0)+instance ToType (Exts.Kind l) where+ toType (Exts.KindStar _) = TH.StarT+ toType (Exts.KindFn _ k1 k2) = toType k1 .->. toType k2+ toType (Exts.KindParen _ kp) = toType kp+ toType (Exts.KindVar _ n) = TH.VarT (toName n)+ -- TODO LumiGuide:+ -- toType (Hs.KindVar _ n)+ -- | isCon (nameBase th_n) = ConT th_n+ -- | otherwise = VarT th_n+ -- where+ -- th_n = toName n+ --+ -- isCon :: String -> Bool+ -- isCon (c:_) = isUpper c || c == ':'+ -- isCon _ = nonsense "toType" "empty kind variable name" n+ toType (Exts.KindApp _ k1 k2) = toType k1 `TH.AppT` toType k2+ toType (Exts.KindTuple _ ks) = foldr (\k pt -> pt `TH.AppT` toType k) (TH.TupleT $ length ks) ks+ toType (Exts.KindList _ k) = TH.ListT `TH.AppT` toType k+#endif++toKind :: Exts.Kind l -> TH.Kind+toKind = toType++toTyVar :: Exts.TyVarBind l -> TyVarBndr_ ()+#if MIN_VERSION_template_haskell(2,17,0)+toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) () (toKind k)+toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n) ()+#else+toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) (toKind k)+toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n)+#endif++#if MIN_VERSION_template_haskell(2,17,0)+toTyVarSpec :: TyVarBndr_ () -> TH.TyVarBndrSpec+toTyVarSpec (TH.KindedTV n () k) = TH.KindedTV n TH.SpecifiedSpec k+toTyVarSpec (TH.PlainTV n ()) = TH.PlainTV n TH.SpecifiedSpec+#else+toTyVarSpec :: TyVarBndr_ flag -> TyVarBndr_ flag+toTyVarSpec = id+#endif++-- TODO (int-index): Use MIN_VERSION_template_haskell(2,21,0)+#if __GLASGOW_HASKELL__ >= 907+toTyVarsVis :: ToTyVars a => a -> [TH.TyVarBndrVis]+toTyVarsVis = map toTyVarVis . toTyVars+ where+ toTyVarVis (TH.KindedTV n () k) = TH.KindedTV n TH.BndrReq k+ toTyVarVis (TH.PlainTV n ()) = TH.PlainTV n TH.BndrReq+#else+toTyVarsVis :: ToTyVars a => a -> [TyVarBndr_ ()]+toTyVarsVis = toTyVars+#endif++instance ToType (Exts.Type l) where+ toType (Exts.TyForall _ tvbM cxt t) = TH.ForallT (maybe [] (fmap (toTyVarSpec . toTyVar)) tvbM) (toCxt cxt) (toType t)+ toType (Exts.TyFun _ a b) = toType a .->. toType b+ toType (Exts.TyList _ t) = TH.ListT `TH.AppT` toType t+ toType (Exts.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts)+ where+ tuple = case b of+ Exts.Boxed -> TH.TupleT+ Exts.Unboxed -> TH.UnboxedTupleT+ toType (Exts.TyApp _ a b) = TH.AppT (toType a) (toType b)+ toType (Exts.TyVar _ n) = TH.VarT (toName n)+ toType (Exts.TyCon _ qn) = TH.ConT (toName qn)+ toType (Exts.TyParen _ t) = toType t+ -- XXX: need to wrap the name in parens!+#if MIN_VERSION_haskell_src_exts(1,20,0)+ -- TODO: why does this branch exist?+ -- Why fail toType if this is a promoted name?+ toType (Exts.TyInfix _ a (Exts.UnpromotedName _ o) b) =+ TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b)+#else+ toType (Exts.TyInfix _ a o b) =+ TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b)+#endif+ toType (Exts.TyKind _ t k) = TH.SigT (toType t) (toKind k)+ toType (Exts.TyPromoted _ p) = case p of+ Exts.PromotedInteger _ i _ -> TH.LitT $ TH.NumTyLit i+ Exts.PromotedString _ _ s -> TH.LitT $ TH.StrTyLit s+ Exts.PromotedCon _ _q n -> TH.PromotedT $ toName n+ Exts.PromotedList _ _q ts -> foldr (\t pl -> TH.PromotedConsT `TH.AppT` toType t `TH.AppT` pl) TH.PromotedNilT ts+ Exts.PromotedTuple _ ts -> foldl (\pt t -> pt `TH.AppT` toType t) (TH.PromotedTupleT $ length ts) ts+ Exts.PromotedUnit _ -> TH.PromotedT ''()+ toType (Exts.TyEquals _ t1 t2) = TH.EqualityT `TH.AppT` toType t1 `TH.AppT` toType t2+ toType t@Exts.TySplice{} = noTH "toType" t+ toType t@Exts.TyBang{} =+ nonsense "toType" "type cannot have strictness annotations in this context" t+ toType t@Exts.TyWildCard{} = noTH "toType" t+ toType t = todo "toType" t+ -- TODO+ -- toType (Exts.TyUnboxedSum _ _)+ -- toType (Exts.TyParArray _ _)+ -- toType (Exts.TyInfix _ _ (Exts.PromotedName _ _) _)++toStrictType :: Exts.Type l -> TH.StrictType+toStrictType (Exts.TyBang _ s u t) = (TH.Bang (toUnpack u) (toStrict s), toType t)+ where+ toStrict (Exts.LazyTy _) = TH.SourceLazy+ toStrict (Exts.BangedTy _) = TH.SourceStrict+ toStrict (Exts.NoStrictAnnot _) = TH.NoSourceStrictness+ toUnpack (Exts.Unpack _) = TH.SourceUnpack+ toUnpack (Exts.NoUnpack _) = TH.SourceNoUnpack+ toUnpack (Exts.NoUnpackPragma _) = TH.NoSourceUnpackedness+toStrictType x = (TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness, toType x)++(.->.) :: TH.Type -> TH.Type -> TH.Type+a .->. b = TH.AppT (TH.AppT TH.ArrowT a) b++instance ToPred (Exts.Asst l) where+#if MIN_VERSION_haskell_src_exts(1,22,0)+ toPred (Exts.TypeA _ t) = toType t+#else+ toPred (Exts.ClassA _ n ts) = List.foldl' TH.AppT (TH.ConT (toName n)) (fmap toType ts)+ toPred (Exts.InfixA _ t1 n t2) = List.foldl' TH.AppT (TH.ConT (toName n)) (fmap toType [t1,t2])+ toPred (Exts.EqualP _ t1 t2) = List.foldl' TH.AppT TH.EqualityT (fmap toType [t1,t2])+ toPred a@Exts.AppA{} = todo "toPred" a+ toPred a@Exts.WildCardA{} = todo "toPred" a+#endif+ toPred (Exts.ParenA _ asst) = toPred asst+ toPred a@Exts.IParam{} = noTH "toPred" a+ -- Pattern match is redundant.+ -- TODO: Is there a way to turn off this warn for catch-alls?+ -- would make the code more future-compat+ -- toPred p = todo "toPred" p++instance ToDerivClauses (Exts.Deriving l) where+#if MIN_VERSION_haskell_src_exts(1,20,0)+ toDerivClauses (Exts.Deriving _ strat irules) = [TH.DerivClause (fmap toDerivStrategy strat) (map toType irules)]+#else+ toDerivClauses (Exts.Deriving _ irules) = [TH.DerivClause Nothing (map toType irules)]+#endif++instance ToDerivClauses a => ToDerivClauses (Maybe a) where+ toDerivClauses Nothing = []+ toDerivClauses (Just a) = toDerivClauses a++instance ToDerivClauses a => ToDerivClauses [a] where+ toDerivClauses = concatMap toDerivClauses+++toDerivStrategy :: (Exts.DerivStrategy l) -> TH.DerivStrategy+toDerivStrategy (Exts.DerivStock _) = TH.StockStrategy+toDerivStrategy (Exts.DerivAnyclass _) = TH.AnyclassStrategy+toDerivStrategy (Exts.DerivNewtype _) = TH.NewtypeStrategy+#if MIN_VERSION_haskell_src_exts(1,21,0) && MIN_VERSION_template_haskell(2,14,0)+toDerivStrategy (Exts.DerivVia _ t) = TH.ViaStrategy (toType t)+#else+toDerivStrategy d@Exts.DerivVia{} = noTHyet "toDerivStrategy" "2.14" d+#endif+++-- TODO LumiGuide+-- instance ToCxt (Hs.Deriving l) where+-- #if MIN_VERSION_haskell_src_exts(1,20,1)+-- toCxt (Hs.Deriving _ _ rule) = toCxt rule+-- #else+-- toCxt (Hs.Deriving _ rule) = toCxt rule+-- #endif++-- instance ToCxt [Hs.InstRule l] where+-- toCxt = concatMap toCxt++-- instance ToCxt a => ToCxt (Maybe a) where+-- toCxt Nothing = []+-- toCxt (Just a) = toCxt a+++foldAppT :: TH.Type -> [TH.Type] -> TH.Type+foldAppT t ts = List.foldl' TH.AppT t ts++-----------------------------------------------------------------------------++-- * ToStmt HsStmt++instance ToStmt (Exts.Stmt l) where+ toStmt (Exts.Generator _ p e) = TH.BindS (toPat p) (toExp e)+ toStmt (Exts.Qualifier _ e) = TH.NoBindS (toExp e)+ toStmt _a@(Exts.LetStmt _ bnds) = TH.LetS (toDecs bnds)+ toStmt s@Exts.RecStmt{} = noTH "toStmt" s+++-----------------------------------------------------------------------------++-- * ToDec HsDecl++instance ToDec (Exts.Decl l) where+ toDec (Exts.TypeDecl _ h t)+ = TH.TySynD (toName h) (toTyVarsVis h) (toType t)++ toDec a@(Exts.DataDecl _ dOrN cxt h qcds qns)+ = case dOrN of+ Exts.DataType _ -> TH.DataD (toCxt cxt)+ (toName h)+ (toTyVarsVis h)+ Nothing+ (fmap qualConDeclToCon qcds)+ (toDerivClauses qns)+ Exts.NewType _ -> let qcd = case qcds of+ [x] -> x+ _ -> nonsense "toDec" ("newtype with " +++ "wrong number of constructors") a+ in TH.NewtypeD (toCxt cxt)+ (toName h)+ (toTyVarsVis h)+ Nothing+ (qualConDeclToCon qcd)+ (toDerivClauses qns)++ -- This type-signature conversion is just wrong.+ -- Type variables need to be dealt with. /Jonas+ toDec _a@(Exts.TypeSig _ ns t)+ -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class!+ = let xs = fmap (flip TH.SigD (toType t) . toName) ns+ in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!"++ toDec (Exts.InlineConlikeSig _ act qn) = TH.PragmaD $+ TH.InlineP (toName qn) TH.Inline TH.ConLike (transAct act)+ toDec (Exts.InlineSig _ b act qn) = TH.PragmaD $+ TH.InlineP (toName qn) inline TH.FunLike (transAct act)+ where+ inline | b = TH.Inline | otherwise = TH.NoInline++ toDec (Exts.TypeFamDecl _ h sig inj)+ = TH.OpenTypeFamilyD $ TH.TypeFamilyHead (toName h)+ (toTyVarsVis h)+ (maybe TH.NoSig TH.KindSig . toMaybeKind $ sig)+ (fmap toInjectivityAnn inj)+ toDec (Exts.DataFamDecl _ _ h sig)+ = TH.DataFamilyD (toName h) (toTyVarsVis h) (toMaybeKind sig)++ toDec _a@(Exts.FunBind _ mtchs) = hsMatchesToFunD mtchs+ toDec (Exts.PatBind _ p rhs bnds) = TH.ValD (toPat p)+ (hsRhsToBody rhs)+ (toDecs bnds)++ toDec i@(Exts.InstDecl _ (Just overlap) _ _) =+ noTH "toDec" (fmap (const ()) overlap, i)++ -- the 'vars' bit seems to be for: instance forall a. C (T a) where ...+ -- TH's own parser seems to flat-out ignore them, and honestly I can't see+ -- that it's obviously wrong to do so.+ toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD+ Nothing+ (toCxt irule)+ (toType irule)+ (toDecs ids)++ toDec (Exts.ClassDecl _ cxt h fds decls) = TH.ClassD+ (toCxt cxt)+ (toName h)+ (toTyVarsVis h)+ (fmap toFunDep fds)+ (toDecs decls)+ where+ toFunDep (Exts.FunDep _ ls rs) = TH.FunDep (fmap toName ls) (fmap toName rs)++ toDec (Exts.AnnPragma _ ann) = TH.PragmaD (TH.AnnP (target ann) (expann ann))+ where+ target (Exts.Ann _ n _) = TH.ValueAnnotation (toName n)+ target (Exts.TypeAnn _ n _) = TH.TypeAnnotation (toName n)+ target (Exts.ModuleAnn _ _) = TH.ModuleAnnotation+ expann (Exts.Ann _ _ e) = toExp e+ expann (Exts.TypeAnn _ _ e) = toExp e+ expann (Exts.ModuleAnn _ e) = toExp e++ toDec x = todo "toDec" x++instance ToMaybeKind (Exts.ResultSig l) where+ toMaybeKind (Exts.KindSig _ k) = Just $ toKind k+ toMaybeKind (Exts.TyVarSig _ _) = Nothing++instance ToMaybeKind a => ToMaybeKind (Maybe a) where+ toMaybeKind Nothing = Nothing+ toMaybeKind (Just a) = toMaybeKind a++instance ToInjectivityAnn (Exts.InjectivityInfo l) where+ toInjectivityAnn (Exts.InjectivityInfo _ n ns) = TH.InjectivityAnn (toName n) (fmap toName ns)++transAct :: Maybe (Exts.Activation l) -> TH.Phases+transAct Nothing = TH.AllPhases+transAct (Just (Exts.ActiveFrom _ n)) = TH.FromPhase n+transAct (Just (Exts.ActiveUntil _ n)) = TH.BeforePhase n++instance ToName (Exts.DeclHead l) where+ toName (Exts.DHead _ n) = toName n+ toName (Exts.DHInfix _ _ n) = toName n+ toName (Exts.DHParen _ h) = toName h+ toName (Exts.DHApp _ h _) = toName h++instance ToTyVars (Exts.DeclHead l) where+ toTyVars (Exts.DHead _ _) = []+ toTyVars (Exts.DHParen _ h) = toTyVars h+ toTyVars (Exts.DHInfix _ tvb _) = [toTyVar tvb]+ toTyVars (Exts.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb]++instance ToNames a => ToNames (Maybe a) where+ toNames Nothing = []+ toNames (Just a) = toNames a++instance ToNames (Exts.Deriving l) where+#if MIN_VERSION_haskell_src_exts(1,20,0)+ toNames (Exts.Deriving _ _ irules) = concatMap toNames irules+#else+ toNames (Exts.Deriving _ irules) = concatMap toNames irules+#endif++instance ToNames (Exts.InstRule l) where+ toNames (Exts.IParen _ irule) = toNames irule+ toNames (Exts.IRule _ _mtvbs _mcxt mihd) = toNames mihd+instance ToNames (Exts.InstHead l) where+ toNames (Exts.IHCon _ n) = [toName n]+ toNames (Exts.IHInfix _ _ n) = [toName n]+ toNames (Exts.IHParen _ h) = toNames h+ toNames (Exts.IHApp _ h _) = toNames h++instance ToCxt (Exts.InstRule l) where+ toCxt (Exts.IRule _ _ cxt _) = toCxt cxt+ toCxt (Exts.IParen _ irule) = toCxt irule++instance ToCxt (Exts.Context l) where+ toCxt x = case x of+ Exts.CxEmpty _ -> []+ Exts.CxSingle _ x' -> [toPred x']+ Exts.CxTuple _ xs -> fmap toPred xs++instance ToCxt a => ToCxt (Maybe a) where+ toCxt Nothing = []+ toCxt (Just a) = toCxt a++instance ToType (Exts.InstRule l) where+ toType (Exts.IRule _ _ _ h) = toType h+ toType (Exts.IParen _ irule) = toType irule++instance ToType (Exts.InstHead l) where+ toType (Exts.IHCon _ qn) = toType qn+ toType (Exts.IHInfix _ typ qn) = TH.AppT (toType typ) (toType qn)+ toType (Exts.IHParen _ hd) = toType hd+ toType (Exts.IHApp _ hd typ) = TH.AppT (toType hd) (toType typ)++qualConDeclToCon :: Exts.QualConDecl l -> TH.Con+qualConDeclToCon (Exts.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl+qualConDeclToCon (Exts.QualConDecl _ ns cxt cdecl) = TH.ForallC (toTyVarSpec <$> toTyVars ns)+ (toCxt cxt)+ (conDeclToCon cdecl)++instance ToTyVars a => ToTyVars (Maybe a) where+ toTyVars Nothing = []+ toTyVars (Just a) = toTyVars a++instance ToTyVars a => ToTyVars [a] where+ toTyVars = concatMap toTyVars++instance ToTyVars (Exts.TyVarBind l) where+ toTyVars tvb = [toTyVar tvb]++instance ToType (Exts.QName l) where+ toType = TH.ConT . toName++conDeclToCon :: Exts.ConDecl l -> TH.Con+conDeclToCon (Exts.ConDecl _ n tys)+ = TH.NormalC (toName n) (map toStrictType tys)+conDeclToCon (Exts.RecDecl _ n fieldDecls)+ = TH.RecC (toName n) (concatMap convField fieldDecls)+ where+ convField :: Exts.FieldDecl l -> [TH.VarStrictType]+ convField (Exts.FieldDecl _ ns t) =+ let (strict, ty) = toStrictType t+ in map (\n' -> (toName n', strict, ty)) ns+conDeclToCon h = todo "conDeclToCon" h+-- TODO+-- (Exts.InfixConDecl _ _ _ _)+++hsMatchesToFunD :: [Exts.Match l] -> TH.Dec+hsMatchesToFunD [] = TH.FunD (TH.mkName []) [] -- errorish+hsMatchesToFunD xs@(Exts.Match _ n _ _ _ : _) = TH.FunD (toName n) (fmap hsMatchToClause xs)+hsMatchesToFunD xs@(Exts.InfixMatch _ _ n _ _ _ : _) = TH.FunD (toName n) (fmap hsMatchToClause xs)+++hsMatchToClause :: Exts.Match l -> TH.Clause+hsMatchToClause (Exts.Match _ _ ps rhs bnds) = TH.Clause+ (fmap toPat ps)+ (hsRhsToBody rhs)+ (toDecs bnds)+hsMatchToClause (Exts.InfixMatch _ p _ ps rhs bnds) = TH.Clause+ (fmap toPat (p:ps))+ (hsRhsToBody rhs)+ (toDecs bnds)++++hsRhsToBody :: Exts.Rhs l -> TH.Body+hsRhsToBody (Exts.UnGuardedRhs _ e) = TH.NormalB (toExp e)+hsRhsToBody (Exts.GuardedRhss _ hsgrhs) =+ let fromGuardedB (TH.GuardedB a) = a+ fromGuardedB h = todo "fromGuardedB" [h]+ -- TODO: (NormalB _)+ in TH.GuardedB . concat+ . fmap (fromGuardedB . hsGuardedRhsToBody)+ $ hsgrhs+++hsGuardedRhsToBody :: Exts.GuardedRhs l -> TH.Body+hsGuardedRhsToBody (Exts.GuardedRhs _ [] e) = TH.NormalB (toExp e)+hsGuardedRhsToBody (Exts.GuardedRhs _ [s] e) = TH.GuardedB [(hsStmtToGuard s, toExp e)]+hsGuardedRhsToBody (Exts.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss+ (pgs,ngs) = unzip [(p,n)+ | (TH.PatG p) <- ss'+ , n@(TH.NormalG _) <- ss']+ e' = toExp e+ patg = TH.PatG (concat pgs)+ in TH.GuardedB $ (patg,e') : zip ngs (repeat e')++++hsStmtToGuard :: Exts.Stmt l -> TH.Guard+hsStmtToGuard (Exts.Generator _ p e) = TH.PatG [TH.BindS (toPat p) (toExp e)]+hsStmtToGuard (Exts.Qualifier _ e) = TH.NormalG (toExp e)+hsStmtToGuard (Exts.LetStmt _ bs) = TH.PatG [TH.LetS (toDecs bs)]+hsStmtToGuard h = todo "hsStmtToGuard" h+-- TODO+-- (Exts.RecStmt _ _)+++-----------------------------------------------------------------------------++-- * ToDecs InstDecl+instance ToDecs (Exts.InstDecl l) where+ toDecs (Exts.InsDecl _ decl) = toDecs decl+ toDecs d = todo "toDec" d++-- * ToDecs HsDecl HsBinds++instance ToDecs (Exts.Decl l) where+ toDecs _a@(Exts.TypeSig _ ns t)+ -- TODO: fixforall as before?+ -- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns+ = let xs = fmap (flip TH.SigD (toType t) . toName) ns+ in xs++ toDecs (Exts.InfixDecl l assoc Nothing ops) =+ toDecs (Exts.InfixDecl l assoc (Just 9) ops)+ toDecs (Exts.InfixDecl _ assoc (Just fixity) ops) =+#if MIN_VERSION_template_haskell(2,22,0)+ map (\op -> TH.InfixD (TH.Fixity fixity dir) TH.NoNamespaceSpecifier (toName op)) ops+#else+ map (\op -> TH.InfixD (TH.Fixity fixity dir) (toName op)) ops+#endif+ where+ dir = case assoc of+ Exts.AssocNone _ -> TH.InfixN+ Exts.AssocLeft _ -> TH.InfixL+ Exts.AssocRight _ -> TH.InfixR++ toDecs a = [toDec a]+++-- TODO: see aboe re: fixforall+-- fixForall t@(TH.ForallT _ _ _) = t+-- fixForall t = case vs of+-- [] -> t+-- _ -> TH.ForallT vs [] t+-- where vs = collectVars t+-- collectVars e = case e of+-- VarT n -> [PlainTV n]+-- AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2+-- TH.ForallT ns _ t -> collectVars t \\ ns+-- _ -> []++instance ToDecs a => ToDecs [a] where+ toDecs a = concatMap toDecs a
+ src/Language/Haskell/Meta/THCompat.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+module Language.Haskell.Meta.THCompat (+ module Language.Haskell.Meta.THCompat+) where++import Language.Haskell.TH.Syntax+++conP :: Name -> [Pat] -> Pat+#if MIN_VERSION_template_haskell(2,18,0)+conP name = ConP name []+#else+conP = ConP+#endif+++#if MIN_VERSION_template_haskell(2,17,0)+plainTV :: Name -> TyVarBndr Specificity+plainTV n = PlainTV n SpecifiedSpec+#else+plainTV :: Name -> TyVarBndr+plainTV = PlainTV+#endif+++#if MIN_VERSION_template_haskell(2,17,0)+type TyVarBndr_ flag = TyVarBndr flag+#else+type TyVarBndr_ flag = TyVarBndr+#endif
src/Language/Haskell/Meta/Utils.hs view
@@ -1,29 +1,77 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell, RankNTypes, StandaloneDeriving,- DeriveDataTypeable, PatternGuards, FlexibleContexts, FlexibleInstances,- TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-} -- | This module is a staging ground -- for to-be-organized-and-merged-nicely code. -module Language.Haskell.Meta.Utils where+module Language.Haskell.Meta.Utils (+ module Language.Haskell.Meta.Utils+) where -import Data.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