haskell-src-meta 0.8.2 → 0.8.3
raw patch · 13 files changed
+790/−553 lines, 13 filesdep +faildep +tastydep +tasty-hunitdep −test-frameworkdep −test-framework-hunitdep ~template-haskellPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: fail, tasty, tasty-hunit
Dependencies removed: test-framework, test-framework-hunit
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
+ Language.Haskell.Meta.Syntax.Translate: instance Language.Haskell.Meta.Syntax.Translate.ToName (Language.Haskell.Exts.Syntax.MaybePromotedName l)
+ Language.Haskell.Meta.Syntax.Translate: type DerivClause = DerivClause
- Language.Haskell.Meta.Syntax.Translate: moduleName :: [Char]
+ Language.Haskell.Meta.Syntax.Translate: moduleName :: String
- Language.Haskell.Meta.Syntax.Translate: toGuard :: () => GuardedRhs l -> (Guard, Exp)
+ Language.Haskell.Meta.Syntax.Translate: toGuard :: GuardedRhs l -> (Guard, Exp)
- Language.Haskell.Meta.Utils: renameThings :: () => (t1 -> t2 -> a1 -> (a2, t1, t2)) -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
+ Language.Haskell.Meta.Utils: renameThings :: (t1 -> t2 -> a1 -> (a2, t1, t2)) -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)
Files
- ChangeLog +3/−0
- examples/BF.hs +38/−16
- examples/Hs.hs +16/−2
- examples/HsHere.hs +44/−16
- examples/SKI.hs +48/−20
- haskell-src-meta.cabal +18/−6
- src/Language/Haskell/Meta.hs +1/−1
- src/Language/Haskell/Meta/Parse.hs +13/−15
- src/Language/Haskell/Meta/Syntax/Translate.hs +499/−400
- src/Language/Haskell/Meta/Utils.hs +79/−58
- tests/Main.hs +14/−9
- tests/Splices.hs +12/−4
- tests/TestExamples.hs +5/−6
ChangeLog view
@@ -1,3 +1,6 @@+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
examples/BF.hs view
@@ -1,24 +1,46 @@-{-# LANGUAGE BangPatterns, TemplateHaskell #-}+-- TODO: knock out these warnings+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-} module BF (- bf,bf2,bfHelloWorld,eval_,parse+ 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,16 +54,16 @@ . 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)|] type Ptr = Int@@ -133,7 +155,7 @@ go !n acc (c :cs) k = go n acc cs k -+test0 :: IO [Bf] test0 = do a <- readFile "prime.bf" return (parse a)
examples/Hs.hs view
@@ -4,12 +4,22 @@ 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,17 +1,42 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-}+-- TODO: knock out these warnings+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-} -module HsHere (here) where+{-# 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 Data.Typeable (Typeable)+import Language.Haskell.Meta (parseExp, parsePat)+import Language.Haskell.Meta.Utils (cleanNames)+import Language.Haskell.TH.Lib hiding (parensP)+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Text.ParserCombinators.ReadP++-- TODO: narrow type & move to shared module+quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a+quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++)++-- TODO: narrow type & move to shared module+quoteDecNotImplemented :: Fail.MonadFail m => String -> m a+quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ )++ data Here = CodeH Exp | TextH String@@ -28,8 +53,8 @@ -- > a x = " random \"text\" "++ show (x + 1) ++"\n something else" here :: QuasiQuoter here = QuasiQuoter- {quoteType = fail "The here quoter is only for expressions and patterns"- ,quoteDec = fail "The here quoter is only for expressions and patterns"+ {quoteType = quoteTypeNotImplemented+ ,quoteDec = quoteDecNotImplemented ,quoteExp = hereExpQ ,quotePat = herePatQ} @@ -44,7 +69,7 @@ hereExpQ :: String -> ExpQ hereExpQ s = case run s of- [] -> fail "here: parse error"+ [] -> fail "here: parse error" e:_ -> lift (cleanNames e) herePatQ :: String -> PatQ@@ -54,7 +79,7 @@ . pprint . cleanNames) e case p of- Left e -> fail e+ Left e -> fail e Right p -> return p run :: String -> [Here]@@ -83,7 +108,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@@ -107,8 +133,10 @@ 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 '['
examples/SKI.hs view
@@ -1,18 +1,43 @@-{-# 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 SKI (SKI(..),ski,parse) where+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-} -import Language.Haskell.Meta (parseExp, parsePat)-import Language.Haskell.TH.Lib hiding (parensP)-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unsafeRunQ)-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 Data.Typeable (Typeable)+import Language.Haskell.Meta (parseExp, parsePat)+import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unsafeRunQ)+import Language.Haskell.TH.Lib hiding (parensP)+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Text.ParserCombinators.ReadP+import Text.PrettyPrint (render)++-- TODO: narrow type & move to shared module+quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a+quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++)++-- TODO: narrow type & move to shared module+quoteDecNotImplemented :: Fail.MonadFail m => String -> m a+quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ )++ data SKI = S | K | I | E Exp | SKI :$ SKI deriving (Eq,Data,Typeable) @@ -37,18 +62,21 @@ ski :: QuasiQuoter ski = QuasiQuoter- {quoteExp = skiExpQ- ,quotePat = skiPatQ}+ { quoteExp = skiExpQ+ , quotePat = skiPatQ+ , quoteType = quoteTypeNotImplemented+ , quoteDec = quoteDecNotImplemented+ } instance Lift SKI where lift = liftSKI liftSKI (E e) = return e liftSKI a = go a- where go S = [|S|]- go K = [|K|]- go I = [|I|]- go (E e) = [|E e|]+ 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 +92,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 +102,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)"
haskell-src-meta.cabal view
@@ -1,5 +1,5 @@ name: haskell-src-meta-version: 0.8.2+version: 0.8.3 cabal-version: >= 1.8 build-type: Simple license: BSD3@@ -9,7 +9,7 @@ copyright: (c) Matt Morrow maintainer: danburton.email@gmail.com bug-reports: https://github.com/DanBurton/haskell-src-meta/issues-tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3+tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.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.@@ -21,7 +21,7 @@ haskell-src-exts >= 1.18 && < 1.22, pretty >= 1.0 && < 1.2, syb >= 0.1 && < 0.8,- template-haskell >= 2.8 && < 2.15,+ template-haskell >= 2.8 && < 2.16, th-orphans >= 0.9.1 && < 0.14 if impl(ghc < 7.8)@@ -44,10 +44,16 @@ haskell-src-exts >= 1.17 && < 1.22, haskell-src-meta, pretty >= 1.0 && < 1.2,- template-haskell >= 2.7 && < 2.15,- test-framework >= 0.8 && < 0.9,- test-framework-hunit >= 0.3 && < 0.4+ template-haskell >= 2.7,+ tasty,+ tasty-hunit + -- this is needed to access Control.Monad.Fail on GHCs before 8.0+ if !impl(ghc >= 8.0)+ Build-Depends:+ fail == 4.9.*++ test-suite splices type: exitcode-stdio-1.0 hs-source-dirs: tests@@ -71,6 +77,12 @@ pretty, syb, template-haskell++ -- this is needed to access Control.Monad.Fail on GHCs before 8.0+ if !impl(ghc >= 8.0)+ Build-Depends:+ fail == 4.9.*+ other-modules: BF,
src/Language/Haskell/Meta.hs view
@@ -14,4 +14,4 @@ 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/Parse.hs view
@@ -30,24 +30,17 @@ ) where #if MIN_VERSION_template_haskell(2,11,0)-import Language.Haskell.TH.Syntax hiding (Extension(..))+import Language.Haskell.TH.Syntax hiding (Extension (..)) #else import Language.Haskell.TH.Syntax #endif-import Language.Haskell.Meta.Syntax.Translate-#if MIN_VERSION_haskell_src_exts(1,18,0)-import qualified Language.Haskell.Exts.Syntax as Hs-import Language.Haskell.Exts.Fixity as Fix-import Language.Haskell.Exts.Parser hiding (parseExp, parseType, parsePat)-#else-import qualified Language.Haskell.Exts.Annotated.Syntax as Hs-import Language.Haskell.Exts.Annotated.Fixity as Fix-import Language.Haskell.Exts.Annotated.Parser hiding (parseExp, parseType, parsePat)-#endif-import qualified Language.Haskell.Exts.SrcLoc as Hs-import Language.Haskell.Exts.Extension-import Language.Haskell.Exts.Pretty-import Language.Haskell.Exts.Parser (ParseMode(..), ParseResult(..))+import Language.Haskell.Exts.Extension+import Language.Haskell.Exts.Parser hiding+ (parseExp, parsePat, parseType)+import Language.Haskell.Exts.Pretty+import qualified Language.Haskell.Exts.SrcLoc as Hs+import qualified Language.Haskell.Exts.Syntax as Hs+import Language.Haskell.Meta.Syntax.Translate ----------------------------------------------------------------------------- @@ -128,6 +121,10 @@ moduleDecls :: Hs.Module Hs.SrcSpanInfo -> [Hs.Decl Hs.SrcSpanInfo] moduleDecls (Hs.Module _ _ _ _ x) = x+moduleDecls m = todo "" m+-- TODO+-- (Hs.XmlPage _ _ _ _ _ _ _)+-- (Hs.XmlHybrid _ _ _ _ _ _ _ _ _) -- mkModule :: String -> Hs.Module -- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] []@@ -141,6 +138,7 @@ [] []) +noSrcSpanInfo :: Hs.SrcSpanInfo noSrcSpanInfo = Hs.noInfoSpan (Hs.mkSrcSpan Hs.noLoc Hs.noLoc) {-
src/Language/Haskell/Meta/Syntax/Translate.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-} {- | Module : Language.Haskell.Meta.Syntax.Translate@@ -13,50 +16,45 @@ module Language.Haskell.Meta.Syntax.Translate ) where -import Data.Char (ord)-import Data.Typeable-import Data.List (foldl', nub, (\\))-import Language.Haskell.TH.Syntax-import qualified Language.Haskell.Exts.SrcLoc as Hs-#if MIN_VERSION_haskell_src_exts(1,18,0)-import qualified Language.Haskell.Exts.Syntax as Hs-#else-import qualified Language.Haskell.Exts.Annotated.Syntax as Hs-#endif+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 qualified Language.Haskell.TH.Syntax as TH ----------------------------------------------------------------------------- -class ToName a where toName :: a -> Name-class ToNames a where toNames :: a -> [Name]-class ToLit a where toLit :: a -> Lit-class ToType a where toType :: a -> Type-class ToPat a where toPat :: a -> Pat-class ToExp a where toExp :: a -> Exp-class ToDecs a where toDecs :: a -> [Dec]-class ToDec a where toDec :: a -> Dec-class ToStmt a where toStmt :: a -> Stmt-class ToLoc a where toLoc :: a -> Loc-class ToCxt a where toCxt :: a -> Cxt-class ToPred a where toPred :: a -> Pred-class ToTyVars a where toTyVars :: a -> [TyVarBndr]-#if MIN_VERSION_haskell_src_exts(1,18,0)-class ToMaybeKind a where toMaybeKind :: a -> Maybe Kind-#endif+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 -> [TH.TyVarBndr]+class ToMaybeKind a where toMaybeKind :: a -> Maybe TH.Kind #if MIN_VERSION_template_haskell(2,11,0)-class ToInjectivityAnn a where toInjectivityAnn :: a -> InjectivityAnn+class ToInjectivityAnn a where toInjectivityAnn :: a -> TH.InjectivityAnn #endif #if MIN_VERSION_template_haskell(2,12,0)+type DerivClause = TH.DerivClause #elif MIN_VERSION_template_haskell(2,11,0)-type DerivClause = Pred+type DerivClause = TH.Pred #else-type DerivClause = Name+type DerivClause = TH.Name #endif 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.@@ -80,42 +78,42 @@ ----------------------------------------------------------------------------- -instance ToExp Lit where- toExp = LitE+instance ToExp TH.Lit where+ toExp = TH.LitE instance (ToExp a) => ToExp [a] where- toExp = ListE . fmap toExp+ toExp = TH.ListE . fmap toExp instance (ToExp a, ToExp b) => ToExp (a,b) where- toExp (a,b) = TupE [toExp a, toExp b]+ toExp (a,b) = TH.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]+ toExp (a,b,c) = TH.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]+ toExp (a,b,c,d) = TH.TupE [toExp a, toExp b, toExp c, toExp d] -instance ToPat Lit where- toPat = LitP+instance ToPat TH.Lit where+ toPat = TH.LitP instance (ToPat a) => ToPat [a] where- toPat = ListP . fmap toPat+ toPat = TH.ListP . fmap toPat instance (ToPat a, ToPat b) => ToPat (a,b) where- toPat (a,b) = TupP [toPat a, toPat b]+ 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) = TupP [toPat a, toPat b, toPat c]+ 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) = TupP [toPat a, toPat b, toPat c, toPat d]+ toPat (a,b,c,d) = TH.TupP [toPat a, toPat b, toPat c, toPat d] instance ToLit Char where- toLit = CharL+ toLit = TH.CharL instance ToLit String where- toLit = StringL+ toLit = TH.StringL instance ToLit Integer where- toLit = IntegerL+ toLit = TH.IntegerL instance ToLit Int where- toLit = IntegerL . toInteger+ toLit = TH.IntegerL . toInteger instance ToLit Float where- toLit = RationalL . toRational+ toLit = TH.RationalL . toRational instance ToLit Double where- toLit = RationalL . toRational+ toLit = TH.RationalL . toRational -----------------------------------------------------------------------------@@ -125,35 +123,51 @@ instance ToName String where- toName = mkName+ toName = TH.mkName -instance ToName (Hs.Name l) where- toName (Hs.Ident _ s) = toName s- toName (Hs.Symbol _ s) = toName s+instance ToName (Exts.Name l) where+ toName (Exts.Ident _ s) = toName s+ toName (Exts.Symbol _ s) = toName s -instance ToName (Hs.SpecialCon l) where- toName (Hs.UnitCon _) = mkName "()"- toName (Hs.ListCon _) = ''[] -- Parser only uses this in types- toName (Hs.FunCon _) = ''(->)- toName (Hs.TupleCon _ _ n) =- mkName $ concat ["(",replicate (n-1) ',',")"]- toName (Hs.Cons _) = '(:)+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 (Hs.QName l) where--- toName (Hs.Qual (Hs.Module []) n) = toName n- toName (Hs.Qual _ (Hs.ModuleName _ []) n) = toName n- toName (Hs.Qual _ (Hs.ModuleName _ m) n) =+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 (Hs.UnQual _ n) = toName n- toName (Hs.Special _ s) = toName s+ 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 (Hs.Op l) where- toName (Hs.VarOp _ n) = toName n- toName (Hs.ConOp _ n) = toName n+instance ToName (Exts.Op l) where+ toName (Exts.VarOp _ n) = toName n+ toName (Exts.ConOp _ n) = toName n -----------------------------------------------------------------------------@@ -161,19 +175,19 @@ -- * ToLit HsLiteral -instance ToLit (Hs.Literal l) where- toLit (Hs.Char _ a _) = CharL a- toLit (Hs.String _ a _) = StringL a- toLit (Hs.Int _ a _) = IntegerL a- toLit (Hs.Frac _ a _) = RationalL a- toLit l@Hs.PrimChar{} = noTH "toLit" l- toLit (Hs.PrimString _ a _) = StringPrimL (map toWord8 a)+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 . ord- toLit (Hs.PrimInt _ a _) = IntPrimL a- toLit (Hs.PrimFloat _ a _) = FloatPrimL a- toLit (Hs.PrimDouble _ a _) = DoublePrimL a- toLit (Hs.PrimWord _ a _) = WordPrimL a+ 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 -----------------------------------------------------------------------------@@ -181,249 +195,294 @@ -- * ToPat HsPat -instance ToPat (Hs.Pat l) where- toPat (Hs.PVar _ n)- = VarP (toName n)- toPat (Hs.PLit _ (Hs.Signless _) l)- = LitP (toLit l)- toPat (Hs.PLit _ (Hs.Negative _) l) = LitP $ case toLit l of- IntegerL z -> IntegerL (negate z)- RationalL q -> RationalL (negate q)- IntPrimL z' -> IntPrimL (negate z')- FloatPrimL r' -> FloatPrimL (negate r')- DoublePrimL r'' -> DoublePrimL (negate r'')- _ -> nonsense "toPat" "negating wrong kind of literal" l- toPat (Hs.PInfixApp _ p n q) = UInfixP (toPat p) (toName n) (toPat q)- toPat (Hs.PApp _ n ps) = ConP (toName n) (fmap toPat ps)- toPat (Hs.PTuple _ Hs.Boxed ps) = TupP (fmap toPat ps)- toPat (Hs.PTuple _ Hs.Unboxed ps) = UnboxedTupP (fmap toPat ps)- toPat (Hs.PList _ ps) = ListP (fmap toPat ps)- toPat (Hs.PParen _ p) = ParensP (toPat p)- toPat (Hs.PRec _ n pfs) = let toFieldPat (Hs.PFieldPat _ n p) = (toName n, toPat p)- in RecP (toName n) (fmap toFieldPat pfs)- toPat (Hs.PAsPat _ n p) = AsP (toName n) (toPat p)- toPat (Hs.PWildCard _) = WildP- toPat (Hs.PIrrPat _ p) = TildeP (toPat p)- toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t)- toPat (Hs.PViewPat _ e p) = ViewP (toExp e) (toPat p)+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) = TH.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@Hs.PRPat{} = noTH "toPat" p+ toPat p@Exts.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@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 (Hs.QOp l) where- toExp (Hs.QVarOp _ n) = VarE (toName n)- toExp (Hs.QConOp _ n) = ConE (toName n)+instance ToExp (Exts.QOp l) where+ toExp (Exts.QVarOp _ n) = TH.VarE (toName n)+ toExp (Exts.QConOp _ n) = TH.ConE (toName n) -toFieldExp :: Hs.FieldUpdate l -> FieldExp-toFieldExp (Hs.FieldUpdate _ n e) = (toName n, toExp e)+toFieldExp :: Exts.FieldUpdate l -> TH.FieldExp+toFieldExp (Exts.FieldUpdate _ n e) = (toName n, toExp e)+toFieldExp h = todo "toFieldExp" h -instance ToExp (Hs.Exp l) where- toExp (Hs.Var _ n) = VarE (toName n)- toExp e@Hs.IPVar{} = noTH "toExp" e- toExp (Hs.Con _ n) = ConE (toName n)- toExp (Hs.Lit _ l) = LitE (toLit l)- toExp (Hs.InfixApp _ e o f) = UInfixE (toExp e) (toExp o) (toExp f)+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)+ toExp (Exts.InfixApp _ e o f) = TH.UInfixE (toExp e) (toExp o) (toExp f) #if MIN_VERSION_template_haskell(2,12,0)- toExp (Hs.App _ e (Hs.TypeApp _ t)) = AppTypeE (toExp e) (toType t)+ toExp (Exts.App _ e (Exts.TypeApp _ t)) = TH.AppTypeE (toExp e) (toType t) #else- toExp (Hs.App _ e aTypeApp@Hs.TypeApp{}) = noTHyet "toExp" "2.12.0" aTypeApp+ toExp (Exts.App _ _ e@Exts.TypeApp{}) = noTHyet "toExp" "2.12.0" e #endif- toExp (Hs.App _ e f) = AppE (toExp e) (toExp f)- toExp (Hs.NegApp _ e) = AppE (VarE 'negate) (toExp e)- toExp (Hs.Lambda _ ps e) = LamE (fmap toPat ps) (toExp e)- toExp (Hs.Let _ bs e) = LetE (toDecs bs) (toExp e)- toExp (Hs.If _ a b c) = CondE (toExp a) (toExp b) (toExp c)- toExp (Hs.MultiIf _ ifs) = MultiIfE (map toGuard ifs)- toExp (Hs.Case _ e alts) = CaseE (toExp e) (map toMatch alts)- toExp (Hs.Do _ ss) = DoE (map toStmt ss)- toExp e@(Hs.MDo _ _) = noTH "toExp" e- toExp (Hs.Tuple _ Hs.Boxed xs) = TupE (fmap toExp xs)- toExp (Hs.Tuple _ Hs.Unboxed xs) = UnboxedTupE (fmap toExp xs)- toExp e@Hs.TupleSection{} = noTH "toExp" e- toExp (Hs.List _ xs) = ListE (fmap toExp xs)- toExp (Hs.Paren _ e) = ParensE (toExp e)- toExp (Hs.LeftSection _ e o) = InfixE (Just . toExp $ e) (toExp o) Nothing- toExp (Hs.RightSection _ o f) = InfixE Nothing (toExp o) (Just . toExp $ f)- toExp (Hs.RecConstr _ n xs) = RecConE (toName n) (fmap toFieldExp xs)- toExp (Hs.RecUpdate _ e xs) = RecUpdE (toExp e) (fmap toFieldExp xs)- toExp (Hs.EnumFrom _ e) = ArithSeqE $ FromR (toExp e)- toExp (Hs.EnumFromTo _ e f) = ArithSeqE $ FromToR (toExp e) (toExp f)- toExp (Hs.EnumFromThen _ e f) = ArithSeqE $ FromThenR (toExp e) (toExp f)- toExp (Hs.EnumFromThenTo _ e f g) = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g)- toExp (Hs.ListComp _ e ss) = CompE $ map convert ss ++ [NoBindS (toExp e)]+ 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)+ toExp (Exts.Do _ ss) = TH.DoE (map toStmt ss)+ toExp e@Exts.MDo{} = noTH "toExp" e+ toExp (Exts.Tuple _ Exts.Boxed xs) = TH.TupE (fmap toExp xs)+ toExp (Exts.Tuple _ Exts.Unboxed xs) = TH.UnboxedTupE (fmap toExp 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 (Hs.QualStmt _ st) = toStmt st- convert s = noTH "toExp ListComp" s- toExp (Hs.ExpTypeSig _ e t) = SigE (toExp e) (toType t)+ 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 :: Hs.Alt l -> Match-toMatch (Hs.Alt _ p rhs ds) = Match (toPat p) (toBody rhs) (toDecs ds)+toMatch :: Exts.Alt l -> TH.Match+toMatch (Exts.Alt _ p rhs ds) = TH.Match (toPat p) (toBody rhs) (toDecs ds) -toBody :: Hs.Rhs l -> Body-toBody (Hs.UnGuardedRhs _ e) = NormalB $ toExp e-toBody (Hs.GuardedRhss _ rhss) = GuardedB $ map toGuard rhss+toBody :: Exts.Rhs l -> TH.Body+toBody (Exts.UnGuardedRhs _ e) = TH.NormalB $ toExp e+toBody (Exts.GuardedRhss _ rhss) = TH.GuardedB $ map toGuard rhss -toGuard (Hs.GuardedRhs _ stmts e) = (g, toExp e)+toGuard :: Exts.GuardedRhs l -> (TH.Guard, TH.Exp)+toGuard (Exts.GuardedRhs _ stmts e) = (g, toExp e) where g = case map toStmt stmts of- [NoBindS x] -> NormalG x- xs -> PatG xs+ [TH.NoBindS x] -> TH.NormalG x+ xs -> TH.PatG xs instance ToDecs a => ToDecs (Maybe a) where- toDecs Nothing = []+ toDecs Nothing = [] toDecs (Just a) = toDecs a -instance ToDecs (Hs.Binds l) where- toDecs (Hs.BDecls _ ds) = toDecs ds- toDecs a@(Hs.IPBinds {}) = noTH "ToDecs Hs.Binds" a+instance ToDecs (Exts.Binds l) where+ toDecs (Exts.BDecls _ ds) = toDecs ds+ toDecs a@(Exts.IPBinds {}) = noTH "ToDecs Exts.Binds" a -instance ToDecs (Hs.ClassDecl l) where- toDecs (Hs.ClsDecl _ d) = toDecs d- toDecs x = todo "classDecl" x+instance ToDecs (Exts.ClassDecl l) where+ toDecs (Exts.ClsDecl _ d) = toDecs d+ toDecs x = todo "classDecl" x ----------------------------------------------------------------------------- -- * ToLoc SrcLoc -instance ToLoc Hs.SrcLoc where- toLoc (Hs.SrcLoc fn l c) =- Loc fn [] [] (l,c) (-1,-1)+instance ToLoc Exts.SrcLoc.SrcLoc where+ toLoc (Exts.SrcLoc.SrcLoc fn l c) =+ TH.Loc fn [] [] (l,c) (-1,-1) ----------------------------------------------------------------------------- -- * ToType HsType -instance ToName (Hs.TyVarBind l) where- toName (Hs.KindedVar _ n _) = toName n- toName (Hs.UnkindedVar _ n) = toName n+instance ToName (Exts.TyVarBind l) where+ toName (Exts.KindedVar _ n _) = toName n+ toName (Exts.UnkindedVar _ n) = toName n -instance ToName Name where+instance ToName TH.Name where toName = id -instance ToName TyVarBndr where- toName (PlainTV n) = n- toName (KindedTV n _) = n+instance ToName TH.TyVarBndr where+ toName (TH.PlainTV n) = n+ toName (TH.KindedTV n _) = n #if !MIN_VERSION_haskell_src_exts(1,21,0)-instance ToType (Hs.Kind l) where- toType (Hs.KindStar _) = StarT- toType (Hs.KindFn _ k1 k2) = toType k1 .->. toType k2- toType (Hs.KindParen _ kp) = toType kp- toType (Hs.KindVar _ n) = VarT (toName n)+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 :: Hs.Kind l -> Kind+toKind :: Exts.Kind l -> TH.Kind toKind = toType -toTyVar :: Hs.TyVarBind l -> TyVarBndr-toTyVar (Hs.KindedVar _ n k) = KindedTV (toName n) (toKind k)-toTyVar (Hs.UnkindedVar _ n) = PlainTV (toName n)+toTyVar :: Exts.TyVarBind l -> TH.TyVarBndr+toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) (toKind k)+toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n) -instance ToType (Hs.Type l) where- toType (Hs.TyForall _ tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t)- toType (Hs.TyFun _ a b) = toType a .->. toType b- toType (Hs.TyList _ t) = ListT `AppT` toType t- toType (Hs.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts)+instance ToType (Exts.Type l) where+ toType (Exts.TyForall _ tvbM cxt t) = TH.ForallT (maybe [] (fmap 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- 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+ 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)- toType (Hs.TyInfix _ a (Hs.UnpromotedName _ o) b) =+ -- 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 (Hs.TyInfix _ a o b) =+ toType (Exts.TyInfix _ a o b) =+ TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b) #endif- AppT (AppT (ConT (toName o)) (toType a)) (toType b)- toType (Hs.TyKind _ t k) = SigT (toType t) (toKind k)- toType t@Hs.TyBang{} =+ 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 -> foldr (\t pt -> pt `TH.AppT` toType t) (TH.PromotedTupleT $ length ts) ts+ Exts.PromotedUnit _ -> TH.PromotedT ''()+#if MIN_VERSION_template_haskell(2,10,0)+ toType (Exts.TyEquals _ t1 t2) = TH.EqualityT `TH.AppT` toType t1 `TH.AppT` toType t2+#else+ toType t@Exts.TyEquals{} = noTHyet "toType" "2.10.0" t+#endif+ 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 :: Hs.Type l -> StrictType+toStrictType :: Exts.Type l -> TH.StrictType #if MIN_VERSION_template_haskell(2,11,0)-toStrictType (Hs.TyBang _ s u t) = (Bang (toUnpack u) (toStrict s), toType t)+toStrictType (Exts.TyBang _ s u t) = (TH.Bang (toUnpack u) (toStrict s), toType t) where- toStrict (Hs.LazyTy _) = SourceLazy- toStrict (Hs.BangedTy _) = SourceStrict- toStrict (Hs.NoStrictAnnot _) = NoSourceStrictness- toUnpack (Hs.Unpack _) = SourceUnpack- toUnpack (Hs.NoUnpack _) = SourceNoUnpack- toUnpack (Hs.NoUnpackPragma _) = NoSourceUnpackedness-toStrictType x = (Bang NoSourceUnpackedness NoSourceStrictness, toType x)-#elif MIN_VERSION_haskell_src_exts(1,18,0)+ 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)+#else+-- TODO: what is this comment? Outdated? -- TyBang l (BangType l) (Unpackedness l) (Type l)--- data BangType l = BangedTy l | LazyTy l | NoStrictAnnot l+-- data BangType l = BangedTy l | LazyTy l | NoStrictAnnot l -- data Unpackedness l = Unpack l | NoUnpack l | NoUnpackPragma l-toStrictType (Hs.TyBang _ b u t) = (toStrict b u, toType t)+toStrictType (Exts.TyBang _ b u t) = (toStrict b u, toType t) where- toStrict :: Hs.BangType l -> Hs.Unpackedness l -> Strict- toStrict (Hs.BangedTy _) _ = IsStrict- toStrict _ (Hs.Unpack _) = Unpacked- toStrict _ _ = NotStrict-toStrictType x = (NotStrict, toType x)-#else-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)+ toStrict :: Exts.BangType l -> Exts.Unpackedness l -> TH.Strict+ toStrict (Exts.BangedTy _) _ = TH.IsStrict+ toStrict _ (Exts.Unpack _) = TH.Unpacked+ toStrict _ _ = TH.NotStrict+toStrictType x = (TH.NotStrict, toType x) #endif --(.->.) :: Type -> Type -> Type-a .->. b = AppT (AppT ArrowT a) b+(.->.) :: TH.Type -> TH.Type -> TH.Type+a .->. b = TH.AppT (TH.AppT TH.ArrowT a) b -instance ToPred (Hs.Asst l) where+instance ToPred (Exts.Asst l) where #if MIN_VERSION_template_haskell(2,10,0)- toPred (Hs.ClassA _ n ts) = foldl' AppT (ConT (toName n)) (fmap toType ts)- toPred (Hs.InfixA _ t1 n t2) = foldl' AppT (ConT (toName n)) (fmap toType [t1,t2])- toPred (Hs.EqualP _ t1 t2) = foldl' AppT EqualityT (fmap toType [t1,t2])+ 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]) #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)+ toPred (Exts.ClassA _ n ts) = TH.ClassP (toName n) (fmap toType ts)+ toPred (Exts.InfixA _ t1 n t2) = TH.ClassP (toName n) (fmap toType [t1, t2])+ toPred (Exts.EqualP _ t1 t2) = TH.EqualP (toType t1) (toType t2) #endif- toPred a@Hs.IParam{} = noTH "toCxt" a- toPred p = todo "toPred" p+ toPred (Exts.ParenA _ asst) = toPred asst+ toPred a@Exts.AppA{} = todo "toPred" a+ toPred a@Exts.WildCardA{} = todo "toPred" a+ 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_template_haskell(2,12,0)-instance ToDerivClauses (Hs.Deriving l) where #if MIN_VERSION_haskell_src_exts(1,20,0)- toDerivClauses (Hs.Deriving _ strat irules) = [DerivClause (fmap toDerivStrategy strat) (map toType irules)]+ toDerivClauses (Exts.Deriving _ strat irules) = [TH.DerivClause (fmap toDerivStrategy strat) (map toType irules)] #else- toDerivClauses (Hs.Deriving _ irules) = [DerivClause Nothing (map toType irules)]+ toDerivClauses (Exts.Deriving _ irules) = [TH.DerivClause Nothing (map toType irules)] #endif-#else-instance ToDerivClauses (Hs.Deriving l) where+#elif MIN_VERSION_template_haskell(2,11,0) #if MIN_VERSION_haskell_src_exts(1,20,0)- toDerivClauses (Hs.Deriving _ _ irules) =+ toDerivClauses (Exts.Deriving _ _ irules) = map toType irules #else- toDerivClauses (Hs.Deriving _ irules) =+ toDerivClauses (Exts.Deriving _ irules) = map toType irules #endif-#if MIN_VERSION_template_haskell(2,11,0)- map toType irules #else- concatMap toNames irules+-- template-haskell < 2.11+#if MIN_VERSION_haskell_src_exts(1,20,0)+ toDerivClauses (Exts.Deriving _ _ irules) = concatMap toNames irules+#else+ toDerivClauses (Exts.Deriving _ irules) = concatMap toNames irules #endif #endif @@ -434,38 +493,64 @@ instance ToDerivClauses a => ToDerivClauses [a] where toDerivClauses = concatMap toDerivClauses + #if MIN_VERSION_template_haskell(2,12,0) && MIN_VERSION_haskell_src_exts(1,20,0)-toDerivStrategy :: (Hs.DerivStrategy l) -> DerivStrategy-toDerivStrategy (Hs.DerivStock _) = StockStrategy-toDerivStrategy (Hs.DerivAnyclass _) = AnyclassStrategy-toDerivStrategy (Hs.DerivNewtype _) = NewtypeStrategy+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)+#if 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+#endif -foldAppT :: Type -> [Type] -> Type-foldAppT t ts = foldl' AppT t ts+#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 (Hs.Stmt l) where- toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e)- toStmt (Hs.Qualifier _ e) = NoBindS (toExp e)- toStmt a@(Hs.LetStmt _ bnds) = LetS (toDecs bnds)- toStmt s@Hs.RecStmt{} = noTH "toStmt" s+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 (Hs.Decl l) where- toDec (Hs.TypeDecl _ h t)- = TySynD (toName h) (toTyVars h) (toType t)+instance ToDec (Exts.Decl l) where+ toDec (Exts.TypeDecl _ h t)+ = TH.TySynD (toName h) (toTyVars h) (toType t) - toDec a@(Hs.DataDecl _ dOrN cxt h qcds qns)+ toDec a@(Exts.DataDecl _ dOrN cxt h qcds qns) = case dOrN of- Hs.DataType _ -> DataD (toCxt cxt)+ Exts.DataType _ -> TH.DataD (toCxt cxt) (toName h) (toTyVars h) #if MIN_VERSION_template_haskell(2,11,0)@@ -473,11 +558,11 @@ #endif (fmap qualConDeclToCon qcds) (toDerivClauses qns)- Hs.NewType _ -> let qcd = case qcds of+ Exts.NewType _ -> let qcd = case qcds of [x] -> x _ -> nonsense "toDec" ("newtype with " ++ "wrong number of constructors") a- in NewtypeD (toCxt cxt)+ in TH.NewtypeD (toCxt cxt) (toName h) (toTyVars h) #if MIN_VERSION_template_haskell(2,11,0)@@ -488,253 +573,267 @@ -- This type-signature conversion is just wrong. -- Type variables need to be dealt with. /Jonas- toDec a@(Hs.TypeSig _ ns t)+ toDec _a@(Exts.TypeSig _ ns t) -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class!- = let xs = fmap (flip SigD (toType t) . toName) ns+ = let xs = fmap (flip TH.SigD (toType t) . toName) ns in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!" - toDec (Hs.InlineConlikeSig _ act qn) = PragmaD $- InlineP (toName qn) Inline ConLike (transAct act)- toDec (Hs.InlineSig _ b act qn) = PragmaD $- InlineP (toName qn) inline FunLike (transAct act)+ 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 = Inline | otherwise = NoInline+ inline | b = TH.Inline | otherwise = TH.NoInline #if MIN_VERSION_template_haskell(2,11,0)- toDec (Hs.TypeFamDecl _ h sig inj)- = OpenTypeFamilyD $ TypeFamilyHead (toName h)+ toDec (Exts.TypeFamDecl _ h sig inj)+ = TH.OpenTypeFamilyD $ TH.TypeFamilyHead (toName h) (toTyVars h)- (maybe NoSig KindSig . toMaybeKind $ sig)+ (maybe TH.NoSig TH.KindSig . toMaybeKind $ sig) (fmap toInjectivityAnn inj)- toDec (Hs.DataFamDecl _ _ h sig)- = DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig)-#elif MIN_VERSION_haskell_src_exts(1,18,0)- toDec (Hs.TypeFamDecl _ h sig inj)- = FamilyD TypeFam (toName h) (toTyVars h) (toMaybeKind sig)- toDec (Hs.DataFamDecl _ _ h sig)- = FamilyD DataFam (toName h) (toTyVars h) (toMaybeKind sig)+ toDec (Exts.DataFamDecl _ _ h sig)+ = TH.DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig) #else- toDec (Hs.TypeFamDecl _ h k)- = FamilyD TypeFam (toName h) (toTyVars h) (fmap toKind k)-- -- TODO: do something with context?- toDec (Hs.DataFamDecl _ _ h k)- = FamilyD DataFam (toName h) (toTyVars h) (fmap toKind k)+ toDec (Exts.TypeFamDecl _ h sig inj)+ = TH.FamilyD TH.TypeFam (toName h) (toTyVars h) (toMaybeKind sig)+ toDec (Exts.DataFamDecl _ _ h sig)+ = TH.FamilyD TH.DataFam (toName h) (toTyVars h) (toMaybeKind sig) #endif - toDec a@(Hs.FunBind _ mtchs) = hsMatchesToFunD mtchs- toDec (Hs.PatBind _ p rhs bnds) = ValD (toPat p)+ toDec _a@(Exts.FunBind _ mtchs) = hsMatchesToFunD mtchs+ toDec (Exts.PatBind _ p rhs bnds) = TH.ValD (toPat p) (hsRhsToBody rhs) (toDecs bnds) - toDec i@(Hs.InstDecl _ (Just overlap) _ _) =+ 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. #if MIN_VERSION_template_haskell(2,11,0)- toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD+ toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD Nothing (toCxt irule) (toType irule) (toDecs ids) #else- toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD+ toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD (toCxt irule) (toType irule) (toDecs ids) #endif - toDec (Hs.ClassDecl _ cxt h fds decls) = ClassD+ toDec (Exts.ClassDecl _ cxt h fds decls) = TH.ClassD (toCxt cxt) (toName h) (toTyVars h) (fmap toFunDep fds) (toDecs decls) where- toFunDep (Hs.FunDep _ ls rs) = FunDep (fmap toName ls) (fmap toName rs)+ toFunDep (Exts.FunDep _ ls rs) = TH.FunDep (fmap toName ls) (fmap toName rs) toDec x = todo "toDec" x -#if MIN_VERSION_haskell_src_exts(1,18,0)-instance ToMaybeKind (Hs.ResultSig l) where- toMaybeKind (Hs.KindSig _ k) = Just $ toKind k- toMaybeKind (Hs.TyVarSig _ _) = Nothing+instance ToMaybeKind (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 Nothing = Nothing toMaybeKind (Just a) = toMaybeKind a-#endif #if MIN_VERSION_template_haskell(2,11,0)-instance ToInjectivityAnn (Hs.InjectivityInfo l) where- toInjectivityAnn (Hs.InjectivityInfo _ n ns) = InjectivityAnn (toName n) (fmap toName ns)+instance ToInjectivityAnn (Exts.InjectivityInfo l) where+ toInjectivityAnn (Exts.InjectivityInfo _ n ns) = TH.InjectivityAnn (toName n) (fmap toName ns) #endif -transAct :: Maybe (Hs.Activation l) -> Phases-transAct Nothing = AllPhases-transAct (Just (Hs.ActiveFrom _ n)) = FromPhase n-transAct (Just (Hs.ActiveUntil _ n)) = BeforePhase n+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 (Hs.DeclHead l) where- toName (Hs.DHead _ n) = toName n- toName (Hs.DHInfix _ _ n) = toName n- toName (Hs.DHParen _ h) = toName h- toName (Hs.DHApp _ h _) = toName h+instance 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 (Hs.DeclHead l) where- toTyVars (Hs.DHead _ _) = []- toTyVars (Hs.DHParen _ h) = toTyVars h- toTyVars (Hs.DHInfix _ tvb _) = [toTyVar tvb]- toTyVars (Hs.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb]+instance 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 Nothing = [] toNames (Just a) = toNames a -instance ToNames (Hs.Deriving l) where+instance ToNames (Exts.Deriving l) where #if MIN_VERSION_haskell_src_exts(1,20,0)- toNames (Hs.Deriving _ _ irules) =+ toNames (Exts.Deriving _ _ irules) = concatMap toNames irules #else- toNames (Hs.Deriving _ irules) =+ toNames (Exts.Deriving _ irules) = concatMap toNames irules #endif- concatMap toNames irules-instance ToNames (Hs.InstRule l) where- toNames (Hs.IParen _ irule) = toNames irule- toNames (Hs.IRule _ _mtvbs _mcxt mihd) = toNames mihd-instance ToNames (Hs.InstHead l) where- toNames (Hs.IHCon _ n) = [toName n]- toNames (Hs.IHInfix _ _ n) = [toName n]- toNames (Hs.IHParen _ h) = toNames h- toNames (Hs.IHApp _ h _) = toNames h -instance ToCxt (Hs.InstRule l) where- toCxt (Hs.IRule _ _ cxt _) = toCxt cxt- toCxt (Hs.IParen _ irule) = toCxt irule+instance 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 (Hs.Context l) where+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- Hs.CxEmpty _ -> []- Hs.CxSingle _ x' -> [toPred x']- Hs.CxTuple _ xs -> fmap toPred xs+ Exts.CxEmpty _ -> []+ Exts.CxSingle _ x' -> [toPred x']+ Exts.CxTuple _ xs -> fmap toPred xs instance ToCxt a => ToCxt (Maybe a) where- toCxt Nothing = []+ toCxt Nothing = [] toCxt (Just a) = toCxt a -instance ToType (Hs.InstRule l) where- toType (Hs.IRule _ _ _ h) = toType h- toType (Hs.IParen _ irule) = toType irule+instance ToType (Exts.InstRule l) where+ toType (Exts.IRule _ _ _ h) = toType h+ toType (Exts.IParen _ irule) = toType irule -instance ToType (Hs.InstHead l) where- toType (Hs.IHCon _ qn) = toType qn- toType (Hs.IHInfix _ typ qn) = AppT (toType typ) (toType qn)- toType (Hs.IHParen _ hd) = toType hd- toType (Hs.IHApp _ hd typ) = AppT (toType hd) (toType typ)+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 :: Hs.QualConDecl l -> Con-qualConDeclToCon (Hs.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl-qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (toTyVars ns)+qualConDeclToCon :: Exts.QualConDecl l -> TH.Con+qualConDeclToCon (Exts.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl+qualConDeclToCon (Exts.QualConDecl _ ns cxt cdecl) = TH.ForallC (toTyVars ns) (toCxt cxt) (conDeclToCon cdecl) instance ToTyVars a => ToTyVars (Maybe a) where- toTyVars Nothing = []+ toTyVars Nothing = [] toTyVars (Just a) = toTyVars a instance ToTyVars a => ToTyVars [a] where toTyVars = concatMap toTyVars -instance ToTyVars (Hs.TyVarBind l) where+instance ToTyVars (Exts.TyVarBind l) where toTyVars tvb = [toTyVar tvb] -instance ToType (Hs.QName l) where- toType = ConT . toName+instance ToType (Exts.QName l) where+ toType = TH.ConT . toName -conDeclToCon :: Hs.ConDecl l -> Con-conDeclToCon (Hs.ConDecl _ n tys)- = NormalC (toName n) (map toStrictType tys)-conDeclToCon (Hs.RecDecl _ n fieldDecls)- = RecC (toName n) (concatMap convField fieldDecls)+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 :: Hs.FieldDecl l -> [VarStrictType]- convField (Hs.FieldDecl _ ns t) =+ 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 :: [Hs.Match l] -> Dec-hsMatchesToFunD [] = FunD (mkName []) [] -- errorish-hsMatchesToFunD xs@(Hs.Match _ n _ _ _ : _) = FunD (toName n) (fmap hsMatchToClause xs)-hsMatchesToFunD xs@(Hs.InfixMatch _ _ n _ _ _ : _) = FunD (toName n) (fmap hsMatchToClause xs)+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 :: Hs.Match l -> Clause-hsMatchToClause (Hs.Match _ _ ps rhs bnds) = Clause+hsMatchToClause :: Exts.Match l -> TH.Clause+hsMatchToClause (Exts.Match _ _ ps rhs bnds) = TH.Clause (fmap toPat ps) (hsRhsToBody rhs) (toDecs bnds)-hsMatchToClause (Hs.InfixMatch _ p _ ps rhs bnds) = Clause+hsMatchToClause (Exts.InfixMatch _ p _ ps rhs bnds) = TH.Clause (fmap toPat (p:ps)) (hsRhsToBody rhs) (toDecs bnds) -hsRhsToBody :: Hs.Rhs l -> Body-hsRhsToBody (Hs.UnGuardedRhs _ e) = NormalB (toExp e)-hsRhsToBody (Hs.GuardedRhss _ hsgrhs) = let fromGuardedB (GuardedB a) = a- in GuardedB . concat- . fmap (fromGuardedB . hsGuardedRhsToBody)- $ hsgrhs-+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 :: Hs.GuardedRhs l -> Body-hsGuardedRhsToBody (Hs.GuardedRhs _ [] e) = NormalB (toExp e)-hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]-hsGuardedRhsToBody (Hs.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss- (pgs,ngs) = unzip [(p,n)- | (PatG p) <- ss'- , n@(NormalG _) <- ss']- e' = toExp e- patg = PatG (concat pgs)- in GuardedB $ (patg,e') : zip ngs (repeat e')+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 :: Hs.Stmt l -> Guard-hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)]-hsStmtToGuard (Hs.Qualifier _ e) = NormalG (toExp e)-hsStmtToGuard (Hs.LetStmt _ bs) = PatG [LetS (toDecs bs)]+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 (Hs.InstDecl l) where- toDecs (Hs.InsDecl _ decl) = toDecs decl- toDecs d = todo "toDec" d+instance ToDecs (Exts.InstDecl l) where+ toDecs (Exts.InsDecl _ decl) = toDecs decl+ toDecs d = todo "toDec" d -- * ToDecs HsDecl HsBinds -instance ToDecs (Hs.Decl l) where- toDecs a@(Hs.TypeSig _ ns t)- = let xs = fmap (flip SigD (toType t) . toName) ns+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 (Hs.InfixDecl l assoc Nothing ops) =- toDecs (Hs.InfixDecl l assoc (Just 9) ops)- toDecs (Hs.InfixDecl _ assoc (Just fixity) ops) =- map (\op -> InfixD (Fixity fixity dir) (toName op)) ops+ toDecs (Exts.InfixDecl l assoc Nothing ops) =+ toDecs (Exts.InfixDecl l assoc (Just 9) ops)+ toDecs (Exts.InfixDecl _ assoc (Just fixity) ops) =+ map (\op -> TH.InfixD (TH.Fixity fixity dir) (toName op)) ops where dir = case assoc of- Hs.AssocNone _ -> InfixN- Hs.AssocLeft _ -> InfixL- Hs.AssocRight _ -> InfixR+ 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/Utils.hs view
@@ -1,25 +1,29 @@-{-# 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 -import Data.List (findIndex)-import Data.Typeable-import Data.Generics hiding(Fixity)+import Control.Monad+import Data.Generics hiding (Fixity)+import Data.List (findIndex)+import Language.Haskell.Exts.Pretty (prettyPrint) 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.Lib hiding (cxt) import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Syntax+import System.IO.Unsafe (unsafePerformIO) import Text.PrettyPrint-import Control.Monad ----------------------------------------------------------------------------- @@ -32,7 +36,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 +45,7 @@ -- but useful in general. pretty :: (Show a) => a -> String pretty a = case parseHsExp (show a) of- Left _ -> []+ Left _ -> [] Right e -> prettyPrint e @@ -81,16 +85,16 @@ 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` ("><.\\/!@#$%^&*-+?:|" :: [Char])) @@ -114,7 +118,7 @@ unForall :: Type -> Type unForall (ForallT _ _ t) = t-unForall t = t+unForall t = t functionT :: [TypeQ] -> TypeQ functionT = foldl1 (|->|)@@ -130,6 +134,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 +152,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)@@ -165,8 +171,8 @@ in (ForallT ns'' cxt' t', env4, new4) where unVarT (VarT n) = 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@@ -179,6 +185,7 @@ (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 +228,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@@ -230,61 +241,61 @@ decCons :: Dec -> [Con] #if MIN_VERSION_template_haskell(2,11,0)-decCons (DataD _ _ _ _ cons _) = cons+decCons (DataD _ _ _ _ cons _) = cons decCons (NewtypeD _ _ _ _ con _) = [con] #else-decCons (DataD _ _ _ cons _) = cons-decCons (NewtypeD _ _ _ con _) = [con]+decCons (DataD _ _ _ cons _) = cons+decCons (NewtypeD _ _ _ con _) = [con] #endif-decCons _ = []+decCons _ = [] decTyVars :: Dec -> [TyVarBndr] #if MIN_VERSION_template_haskell(2,11,0)-decTyVars (DataD _ _ ns _ _ _) = ns+decTyVars (DataD _ _ ns _ _ _) = ns decTyVars (NewtypeD _ _ ns _ _ _) = ns #else-decTyVars (DataD _ _ ns _ _) = ns-decTyVars (NewtypeD _ _ ns _ _) = ns+decTyVars (DataD _ _ ns _ _) = ns+decTyVars (NewtypeD _ _ ns _ _) = ns #endif-decTyVars (TySynD _ ns _) = ns-decTyVars (ClassD _ _ ns _ _) = ns-decTyVars _ = []+decTyVars (TySynD _ ns _) = ns+decTyVars (ClassD _ _ ns _ _) = ns+decTyVars _ = [] decName :: Dec -> Maybe Name-decName (FunD n _) = Just n+decName (FunD n _) = Just n #if MIN_VERSION_template_haskell(2,11,0)-decName (DataD _ n _ _ _ _) = Just n+decName (DataD _ n _ _ _ _) = Just n decName (NewtypeD _ n _ _ _ _) = Just n #else-decName (DataD _ n _ _ _) = Just n-decName (NewtypeD _ n _ _ _) = Just n+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+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+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 +319,52 @@ -- | 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+recCName _ = Nothing dataDCons :: Dec -> [Con] #if MIN_VERSION_template_haskell(2,11,0) dataDCons (DataD _ _ _ _ cons _) = cons #else-dataDCons (DataD _ _ _ cons _) = cons+dataDCons (DataD _ _ _ cons _) = cons #endif-dataDCons _ = []+dataDCons _ = [] fromDataConI :: Info -> Q (Maybe Exp) #if MIN_VERSION_template_haskell(2,11,0)-fromDataConI (DataConI dConN ty tyConN) =+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))) #else-fromDataConI (DataConI dConN ty tyConN fxty) =-#endif+fromDataConI (DataConI dConN ty _tyConN _fxty) = let n = arityT ty in replicateM n (newName "a") >>= \ns -> return (Just (LamE [ConP dConN (fmap VarP ns)] (TupE $ fmap VarE ns)))++#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) []]
tests/Main.hs view
@@ -2,17 +2,22 @@ module Main where -import Language.Haskell.Meta.Parse-import qualified Language.Haskell.Exts as Exts+import qualified Control.Monad.Fail as Fail+import qualified Language.Haskell.Exts as Exts import qualified Language.Haskell.Exts.Extension as Extension-import qualified Language.Haskell.Exts.Parser as Parser-import qualified Language.Haskell.TH as TH-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit (Assertion, (@?=))+import qualified Language.Haskell.Exts.Parser as Parser+import Language.Haskell.Meta.Parse+import qualified Language.Haskell.TH as TH+-- import Test.Framework+-- import Test.Framework.Providers.HUnit+import Test.HUnit (Assertion, (@?=))+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (testCase) +type Test = TestTree+ main :: IO ()-main = defaultMain tests+main = defaultMain (testGroup "unit" tests) tests :: [Test] tests = [ derivingClausesTest@@ -44,5 +49,5 @@ declsExts' <- liftEither $ parseDecsWithMode mode s >>= parseHsDeclsWithMode mode . TH.pprint declsExts' @?= declsExts -liftEither :: Monad m => Either String a -> m a+liftEither :: Fail.MonadFail m => Either String a -> m a liftEither = either fail return
tests/Splices.hs view
@@ -1,8 +1,15 @@-{-# LANGUAGE CPP, TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++#if MIN_VERSION_template_haskell(2,12,0)+{-# LANGUAGE TypeApplications #-}+#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+import qualified Language.Haskell.Exts.Parser as Parser+import qualified Language.Haskell.Meta as Meta ----- Testing names ----- @@ -53,8 +60,9 @@ -- Just to check that it works as intended+main :: IO () main = do- -9 <- return $(either error return $ Meta.parseExp "-3^2") :: IO Int+ -9 <- return $(either error return $ Meta.parseExp "-3^2 :: Int") :: IO Int () <- unit [] <- return (nilp []) (1,2) <- return pair
tests/TestExamples.hs view
@@ -1,13 +1,12 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}--import Control.Monad (when)+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-} import qualified BF import qualified Hs import qualified HsHere import qualified SKI -import SKI (SKI(S, K, I, (:$)))+import SKI (SKI ((:$), I, K, S)) -- Very dumb test framework shouldBe :: (Show a, Eq a) => a -> a -> IO ()@@ -27,7 +26,7 @@ hereTest :: IO () hereTest = do- a 3 `shouldBe` (" random \"text\" "++ show (3 + 1) ++"\n something else")+ a 3 `shouldBe` (" random \"text\" "++ show (3 + 1 :: Int) ++"\n something else") -- TODO: better test exercising the bf quasiquoter @@ -37,7 +36,7 @@ hsTest :: IO () hsTest = do- (\ [Hs.hs|a@(x,_)|] -> [Hs.hs|(a,x)|]) (42,88) `shouldBe` ((42,88),42)+ (\ [Hs.hs|b@(x,_)|] -> [Hs.hs|(b,x)|]) (42 :: Int,88 :: Int) `shouldBe` ((42,88),42) -- TODO: better test exercising the ski quasiquoter