haskell-src-meta 0.6.0.14 → 0.7.0

raw patch · 6 files changed

+382/−302 lines, 6 filesdep ~basedep ~haskell-src-extsdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, haskell-src-exts, template-haskell

API changes (from Hackage documentation)

Files

• haskell-src-meta.cabal +3/−11
• src/Language/Haskell/Meta.hs +0/−1
• src/Language/Haskell/Meta/Parse.hs +23/−20
• src/Language/Haskell/Meta/Parse/Careful.hs +5/−5
• src/Language/Haskell/Meta/Syntax/Translate.hs +350/−264
• src/Language/Haskell/TH/Instances/Lift.hs +1/−1

@@ -1,5 +1,5 @@ name:               haskell-src-meta-version:            0.6.0.14+version:            0.7.0 cabal-version:      >= 1.6 build-type:         Simple license:            BSD3@@ -10,7 +10,7 @@ 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+tested-with:        GHC == 7.6.3, GHC == 7.8.3, GHC == 7.10.3, GHC == 8.0.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.@@ -19,19 +19,11 @@  library   build-depends:   base >= 4.5 && < 4.10,+                   haskell-src-exts >= 1.17 && < 1.19,                    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.*    extensions:      CPP,                    RankNTypes,

@@ -1,4 +1,3 @@- {- |   Module      :  Language.Haskell.Meta   Copyright   :  (c) Matt Morrow 2008

@@ -23,7 +23,7 @@   parseHsPat,   pprHsModule,   moduleDecls,-  emptySrcLoc,+  noSrcSpanInfo,   emptyHsModule  ) where @@ -33,11 +33,19 @@ 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.Parser hiding (parseExp, parseType, parsePat) import Language.Haskell.Exts.Pretty+import Language.Haskell.Exts.Parser (ParseMode(..), ParseResult(..))  ----------------------------------------------------------------------------- @@ -67,9 +75,7 @@   ,ignoreLinePragmas = False   ,ignoreLanguagePragmas = False   ,fixities = Nothing-#if MIN_VERSION_haskell_src_exts(1,17,0)   ,ignoreFunctionArity = False-#endif   }  myDefaultExtensions :: [KnownExtension]@@ -90,47 +96,44 @@   = 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 :: String -> Either String [Hs.Decl Hs.SrcSpanInfo] parseHsDecls = either Left (Right . moduleDecls)   . parseResultToEither . parseModuleWithMode myDefaultParseMode  -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  -- 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.noInfoSpan (Hs.mkSrcSpan Hs.noLoc Hs.noLoc)  {- ghci> :i Module

@@ -26,9 +26,9 @@  -} module Language.Haskell.Meta.Parse.Careful(-  parsePat, -  parseExp, -  parseType, +  parsePat,+  parseExp,+  parseType,   parseDecs  ) where @@ -37,8 +37,8 @@ import qualified Language.Haskell.TH as TH import qualified Language.Haskell.Exts.Syntax as Hs -doChecked parser translater p = -  case parser p of +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')

@@ -17,12 +17,18 @@ import Data.Typeable import Data.List (foldl', nub, (\\)) import Language.Haskell.TH.Syntax+import qualified Language.Haskell.Exts.SrcLoc as Hs+#if MIN_VERSION_haskell_src_exts(1,18,0) import qualified Language.Haskell.Exts.Syntax as Hs+#else+import qualified Language.Haskell.Exts.Annotated.Syntax as Hs+#endif  -----------------------------------------------------------------------------   class ToName a where toName :: a -> Name+class ToNames a where toNames :: a -> [Name] class ToLit  a where toLit  :: a -> Lit class ToType a where toType :: a -> Type class ToPat  a where toPat  :: a -> Pat@@ -32,27 +38,35 @@ class ToStmt a where toStmt :: a -> Stmt class ToLoc  a where toLoc  :: a -> Loc class ToCxt  a where toCxt  :: a -> Cxt+class ToPred a where toPred :: a -> Pred+class ToTyVars a where toTyVars :: a -> [TyVarBndr]+#if MIN_VERSION_haskell_src_exts(1,18,0)+class ToMaybeKind a where toMaybeKind :: a -> Maybe Kind+#if MIN_VERSION_template_haskell(2,11,0)+class ToInjectivityAnn a where toInjectivityAnn :: a -> InjectivityAnn+#endif+#endif  -- for error messages moduleName = "Language.Haskell.Meta.Syntax.Translate"  -- When to use each of these isn't always clear: prefer 'todo' if unsure.-noTH :: Show e => String -> e -> a+noTH :: (Functor f, Show (f ())) => String -> f e -> a noTH fun thing = error . concat $ [moduleName, ".", fun,-  ": template-haskell has no representation for: ", show thing]+  ": template-haskell has no representation for: ", show (fmap (const ()) thing)] -noTHyet :: Show e => String -> String -> e -> a+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 thing]+  " has no representation for: ", show (fmap (const ()) thing)] -todo :: Show e => String -> e -> a+todo :: (Functor f, Show (f ())) => String -> f e -> a todo fun thing = error . concat $ [moduleName, ".", fun,-  ": not implemented: ", show thing]+  ": not implemented: ", show (fmap (const ()) thing)] -nonsense :: Show e => String -> String -> e -> a+nonsense :: (Functor f, Show (f ())) => String -> String -> f e -> a nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun,-  ": nonsensical: ", inparticular, ": ", show thing]+  ": nonsensical: ", inparticular, ": ", show (fmap (const ()) thing)]  ----------------------------------------------------------------------------- @@ -104,40 +118,36 @@ 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.Name l) where+  toName (Hs.Ident _ s) = toName s+  toName (Hs.Symbol _ s) = toName s -instance ToName Hs.SpecialCon where-  toName Hs.UnitCon = '()-  toName Hs.ListCon = '[]-  toName Hs.FunCon  = ''(->)-  toName (Hs.TupleCon _ n)+instance ToName (Hs.SpecialCon l) where+  toName (Hs.UnitCon _) = '()+  toName (Hs.ListCon _) = '[]+  toName (Hs.FunCon _)  = ''(->)+  toName (Hs.TupleCon _ _ n)     | n<2 = '()     | otherwise =       let x = maybe [] (++".") (nameModule '(,))       in mkName . concat $ x : ["(",replicate (n-1) ',',")"]-  toName Hs.Cons    = '(:)+  toName (Hs.Cons _)    = '(:)  -instance ToName Hs.QName where+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) =+  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+  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+instance ToName (Hs.Op l) where+  toName (Hs.VarOp _ n) = toName n+  toName (Hs.ConOp _ n) = toName n   -----------------------------------------------------------------------------@@ -145,23 +155,19 @@ -- * 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+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-#if MIN_VERSION_template_haskell(2,8,0)-  toLit (Hs.PrimString a) = StringPrimL (map toWord8 a)+  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+  toLit (Hs.PrimInt _ a _) = IntPrimL a+  toLit (Hs.PrimFloat _ a _) = FloatPrimL a+  toLit (Hs.PrimDouble _ a _) = DoublePrimL a+  toLit (Hs.PrimWord _ a _) = WordPrimL a   -----------------------------------------------------------------------------@@ -169,31 +175,31 @@ -- * ToPat HsPat  -instance ToPat Hs.Pat where-  toPat (Hs.PVar n)+instance ToPat (Hs.Pat l) where+  toPat (Hs.PVar _ n)     = VarP (toName n)-  toPat (Hs.PLit Hs.Signless l)+  toPat (Hs.PLit _ (Hs.Signless _) l)     = LitP (toLit l)-  toPat (Hs.PLit Hs.Negative l) = LitP $ case toLit l of+  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.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)+  toPat (Hs.PViewPat _ e p) = ViewP (toExp e) (toPat p)   -- regular pattern   toPat p@Hs.PRPat{} = noTH "toPat" p   -- XML stuff@@ -201,69 +207,65 @@   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 (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)+instance ToExp (Hs.QOp l) 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)+toFieldExp :: Hs.FieldUpdate l -> FieldExp+toFieldExp (Hs.FieldUpdate _ n e) = (toName n, toExp e)    -instance ToExp Hs.Exp where-  toExp (Hs.Var n)                 = VarE (toName n)+instance ToExp (Hs.Exp l) where+  toExp (Hs.Var _ n)                 = VarE (toName n)   toExp e@Hs.IPVar{}               = noTH "toExp" e-  toExp (Hs.Con n)                 = ConE (toName n)-  toExp (Hs.Lit l)                 = LitE (toLit l)-  toExp (Hs.InfixApp e o f)        = UInfixE (toExp e) (toExp o) (toExp f)-  toExp (Hs.App e f)               = AppE (toExp e) (toExp f)-  toExp (Hs.NegApp e)              = AppE (VarE 'negate) (toExp e)+  toExp (Hs.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 (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 (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 (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 l -> 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+toBody :: Hs.Rhs l -> Body+toBody (Hs.UnGuardedRhs _ e) = NormalB $ toExp e+toBody (Hs.GuardedRhss _ rhss) = GuardedB $ map toGuard rhss  toGuard (Hs.GuardedRhs _ stmts e) = (g, toExp e)   where@@ -271,7 +273,18 @@       [NoBindS x] -> NormalG x       xs -> PatG xs +instance ToDecs a => ToDecs (Maybe a) where+    toDecs Nothing = []+    toDecs (Just a) = toDecs a +instance ToDecs (Hs.Binds l) where+  toDecs (Hs.BDecls _ ds)   = toDecs ds+  toDecs a@(Hs.IPBinds {}) = noTH "ToDecs Hs.Binds" a++instance ToDecs (Hs.ClassDecl l) where+  toDecs (Hs.ClsDecl _ d) = toDecs d+  toDecs x = todo "classDecl" x+ -----------------------------------------------------------------------------  -- * ToLoc SrcLoc@@ -284,9 +297,9 @@  -- * ToType HsType -instance ToName Hs.TyVarBind where-  toName (Hs.KindedVar n _) = toName n-  toName (Hs.UnkindedVar n) = toName n+instance ToName (Hs.TyVarBind l) where+  toName (Hs.KindedVar _ n _) = toName n+  toName (Hs.UnkindedVar _ n) = toName n  instance ToName Name where   toName = id@@ -295,99 +308,109 @@   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)+instance ToType (Hs.Kind l) where+  toType (Hs.KindStar _) = StarT+  toType (Hs.KindFn _ k1 k2) = toType k1 .->. toType k2+  toType (Hs.KindParen _ kp) = toType kp+  toType (Hs.KindVar _ n) = VarT (toName n) -toKind :: Hs.Kind -> Kind+toKind :: Hs.Kind l -> 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)+toTyVar :: Hs.TyVarBind l -> TyVarBndr+toTyVar (Hs.KindedVar _ n k) = KindedTV (toName n) (toKind k)+toTyVar (Hs.UnkindedVar _ n) = PlainTV (toName n) -instance ToType Hs.Type 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 (Hs.Type l) where+  toType (Hs.TyForall _ tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t)+  toType (Hs.TyFun _ a b) = toType a .->. toType b+  toType (Hs.TyList _ t) = ListT `AppT` toType t+  toType (Hs.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts)    where     tuple = case b of       Hs.Boxed -> TupleT       Hs.Unboxed -> UnboxedTupleT-  toType (Hs.TyApp a b) = AppT (toType a) (toType b)-  toType (Hs.TyVar n) = VarT (toName n)-  toType (Hs.TyCon qn) = ConT (toName qn)-  toType (Hs.TyParen t) = toType t+  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 (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+toStrictType :: Hs.Type l -> StrictType+#if MIN_VERSION_haskell_src_exts(1,18,0) #if MIN_VERSION_template_haskell(2,11,0)-toStrictType (Hs.TyBang Hs.UnpackedTy t) = toStrictType2 SourceUnpack t+toStrictType (Hs.TyBang _ s u t) = (Bang (toUnpack u) (toStrict s), toType t)+    where+      toStrict (Hs.LazyTy _) = SourceLazy+      toStrict (Hs.BangedTy _) = SourceStrict+      toStrict (Hs.NoStrictAnnot _) = NoSourceStrictness+      toUnpack (Hs.Unpack _) = SourceUnpack+      toUnpack (Hs.NoUnpack _) = SourceNoUnpack+      toUnpack (Hs.NoUnpackPragma _) = NoSourceUnpackedness+#else+-- TyBang l (BangType l) (Unpackedness l) (Type l)+-- data BangType l = BangedTy l	| LazyTy l | NoStrictAnnot l+-- data Unpackedness l = Unpack l | NoUnpack l | NoUnpackPragma l+toStrictType (Hs.TyBang _ b u t) = (toStrict b u, toType t)+    where+      toStrict :: Hs.BangType l -> Hs.Unpackedness l -> Strict+      toStrict (Hs.BangedTy _) _ = IsStrict+      toStrict _ (Hs.Unpack _) = Unpacked+      toStrict _ _ = NotStrict+#endif+#else+#if MIN_VERSION_template_haskell(2,11,0)+toStrictType (Hs.TyBang _ (Hs.UnpackedTy _) t) = toStrictType2 SourceUnpack t toStrictType t = toStrictType2 NoSourceUnpackedness t -toStrictType2 u t@(Hs.TyBang _ Hs.TyBang{}) =+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) =+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{}) =+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 (Hs.TyBang _ (Hs.BangedTy _) t) = (IsStrict, toType t)+toStrictType (Hs.TyBang _ (Hs.UnpackedTy _) t) = (Unpacked, toType t) toStrictType t = (NotStrict, toType t) #endif /* !MIN_VERSION_template_haskell(2,11,0) */+#endif   (.->.) :: Type -> Type -> Type a .->. b = AppT (AppT ArrowT a) b -instance ToCxt Hs.Context where-  toCxt = fmap toPred-   where+instance ToPred (Hs.Asst l) where #if MIN_VERSION_template_haskell(2,10,0)-    toPred (Hs.ClassA n ts) = foldl' AppT (ConT (toName n)) (fmap toType ts)-    toPred (Hs.InfixA t1 n t2) = foldl' AppT (ConT (toName n)) (fmap toType [t1,t2])-    toPred (Hs.EqualP t1 t2) = foldl' AppT EqualityT (fmap toType [t1,t2])+    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)+    toPred (Hs.ClassA _ n ts) = ClassP (toName n) (fmap toType ts)+    toPred (Hs.InfixA _ t1 n t2) = ClassP (toName n) (fmap toType [t1, t2])+    toPred (Hs.EqualP _ t1 t2) = EqualP (toType t1) (toType t2) #endif     toPred a@Hs.IParam{} = noTH "toCxt" a+    toPred p = todo "toPred" p  #if MIN_VERSION_template_haskell(2,11,0)-instance ToCxt [Hs.Deriving] where-  toCxt = fmap toPred-   where-    toPred (qn, ts) = foldl' AppT (ConT (toName qn)) (fmap toType ts)+instance ToCxt (Hs.Deriving l) where+  toCxt (Hs.Deriving _ rule) = toCxt rule+instance ToCxt [Hs.InstRule l] where+  toCxt = concatMap toCxt #endif +instance ToCxt a => ToCxt (Maybe a) where+    toCxt Nothing = []+    toCxt (Just a) = toCxt a+ foldAppT :: Type -> [Type] -> Type foldAppT t ts = foldl' AppT t ts @@ -395,10 +418,10 @@  -- * ToStmt HsStmt -instance ToStmt Hs.Stmt where+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 (Hs.Qualifier _ e)      = NoBindS (toExp e)+  toStmt a@(Hs.LetStmt _ bnds)   = LetS (toDecs bnds)   toStmt s@Hs.RecStmt{}        = noTH "toStmt" s  @@ -406,15 +429,15 @@  -- * ToDec HsDecl -instance ToDec Hs.Decl where-  toDec (Hs.TypeDecl _ n ns t)-    = TySynD (toName n) (fmap toTyVar ns) (toType t)+instance ToDec (Hs.Decl l) where+  toDec (Hs.TypeDecl _ h t)+    = TySynD (toName h) (toTyVars h) (toType t) -  toDec a@(Hs.DataDecl  _ dOrN cxt n ns qcds qns)+  toDec a@(Hs.DataDecl  _ dOrN cxt h qcds qns)     = case dOrN of-        Hs.DataType -> DataD (toCxt cxt)-                             (toName n)-                             (fmap toTyVar ns)+        Hs.DataType _ -> DataD (toCxt cxt)+                             (toName h)+                             (toTyVars h) #if MIN_VERSION_template_haskell(2,11,0)                              Nothing #endif@@ -422,15 +445,15 @@ #if MIN_VERSION_template_haskell(2,11,0)                              (toCxt qns) #else-                             (fmap (toName . fst) qns)+                             (toNames qns) #endif-        Hs.NewType  -> let qcd = case qcds of-                                  [x] -> x-                                  _   -> nonsense "toDec" ("newtype with " ++-                                           "wrong number of constructors") a+        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)+                                    (toName h)+                                    (toTyVars h) #if MIN_VERSION_template_haskell(2,11,0)                                     Nothing #endif@@ -438,18 +461,16 @@ #if MIN_VERSION_template_haskell(2,11,0)                                     (toCxt qns) #else-                                    (fmap (toName . fst) qns)+                                    (toNames qns) #endif -  -- This type-signature conversion is just wrong. +  -- 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 $@@ -457,124 +478,198 @@    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)+#if MIN_VERSION_haskell_src_exts(1,18,0)+  toDec (Hs.TypeFamDecl _ h sig inj)+    = OpenTypeFamilyD $ TypeFamilyHead (toName h)+                                       (toTyVars h)+                                       (maybe NoSig KindSig . toMaybeKind $ sig)+                                       (fmap toInjectivityAnn inj)+  toDec (Hs.DataFamDecl _ _ h sig)+    = DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig)+#else+  toDec (Hs.TypeFamDecl _ h k)+    = OpenTypeFamilyD $ TypeFamilyHead (toName h)+                                       (toTyVars h)                                        (maybe NoSig (KindSig . toKind) k)                                        Nothing-   -- TODO: do something with context?-  toDec (Hs.DataFamDecl _ _ n ns k)-    = DataFamilyD (toName n) (fmap toTyVar ns) (fmap toKind k)+  toDec (Hs.DataFamDecl _ _ h k)+    = DataFamilyD (toName h) (toTyVars h) (fmap toKind k)+#endif+ #else-  toDec (Hs.TypeFamDecl _ n ns k)-    = FamilyD TypeFam (toName n) (fmap toTyVar ns) (fmap toKind k)+#if MIN_VERSION_haskell_src_exts(1,18,0)+  toDec (Hs.TypeFamDecl _ h sig inj)+    = FamilyD TypeFam (toName h) (toTyVars h) (toMaybeKind sig)+  toDec (Hs.DataFamDecl _ _ h sig)+    = FamilyD DataFam (toName h) (toTyVars h) (toMaybeKind sig)+#else+  toDec (Hs.TypeFamDecl _ h k)+    = FamilyD TypeFam (toName h) (toTyVars h) (fmap toKind k)    -- TODO: do something with context?-  toDec (Hs.DataFamDecl _ _ n ns k)-    = FamilyD DataFam (toName n) (fmap toTyVar ns) (fmap toKind k)+  toDec (Hs.DataFamDecl _ _ h k)+    = FamilyD DataFam (toName h) (toTyVars h) (fmap toKind k)+#endif #endif /* MIN_VERSION_template_haskell(2,11,0) */ -  toDec a@(Hs.FunBind mtchs)                           = hsMatchesToFunD mtchs+  toDec 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)+  toDec i@(Hs.InstDecl _ (Just overlap) _ _) =+    noTH "toDec" (fmap (const ()) overlap, i)    -- the 'vars' bit seems to be for: instance forall a. C (T a) where ...   -- TH's own parser seems to flat-out ignore them, and honestly I can't see   -- that it's obviously wrong to do so. #if MIN_VERSION_template_haskell(2,11,0)-  toDec (Hs.InstDecl _ Nothing _vars cxt qname ts ids) = InstanceD +  toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD     Nothing-    (toCxt cxt) -    (foldl AppT (ConT (toName qname)) (map toType ts))+    (toCxt irule)+    (toType irule)     (toDecs ids) #else-  toDec (Hs.InstDecl _ Nothing _vars cxt qname ts ids) = InstanceD -    (toCxt cxt) -    (foldl AppT (ConT (toName qname)) (map toType ts))+  toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD+    (toCxt irule)+    (toType irule)     (toDecs ids) #endif -  toDec (Hs.ClassDecl _ cxt name ts fds decls) = ClassD+  toDec (Hs.ClassDecl _ cxt h fds decls) = ClassD     (toCxt cxt)-    (toName name)-    (fmap toTyVar ts)+    (toName h)+    (toTyVars h)     (fmap toFunDep fds)-    (fmap classDeclToDec decls)+    (toDecs 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)+    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)+#if MIN_VERSION_haskell_src_exts(1,18,0)+instance ToMaybeKind (Hs.ResultSig l) where+    toMaybeKind (Hs.KindSig _ k) = Just $ toKind k+    toMaybeKind (Hs.TyVarSig _ _) = Nothing++instance ToMaybeKind a => ToMaybeKind (Maybe a) where+    toMaybeKind Nothing = Nothing+    toMaybeKind (Just a) = toMaybeKind a++#if MIN_VERSION_template_haskell(2,11,0)+instance ToInjectivityAnn (Hs.InjectivityInfo l) where+  toInjectivityAnn (Hs.InjectivityInfo _ n ns) = InjectivityAnn (toName n) (fmap toName ns) #endif+#endif +transAct :: Maybe (Hs.Activation l) -> Phases+transAct Nothing = AllPhases+transAct (Just (Hs.ActiveFrom _ n)) = FromPhase n+transAct (Just (Hs.ActiveUntil _ n)) = BeforePhase n -qualConDeclToCon :: Hs.QualConDecl -> Con-qualConDeclToCon (Hs.QualConDecl _ [] [] cdecl) = conDeclToCon cdecl-qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toTyVar ns)+instance ToName (Hs.DeclHead l) where+  toName (Hs.DHead _ n) = toName n+  toName (Hs.DHInfix _ _ n) = toName n+  toName (Hs.DHParen _ h) = toName h+  toName (Hs.DHApp _ h _) = toName h++instance ToTyVars (Hs.DeclHead l) where+  toTyVars (Hs.DHead _ _) = []+  toTyVars (Hs.DHParen _ h) = toTyVars h+  toTyVars (Hs.DHInfix _ tvb _) = [toTyVar tvb]+  toTyVars (Hs.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb]++instance ToNames a => ToNames (Maybe a) where+  toNames Nothing = []+  toNames (Just a) = toNames a++instance ToNames (Hs.Deriving l) where+  toNames (Hs.Deriving _ irules) = concatMap toNames irules+instance ToNames (Hs.InstRule l) where+  toNames (Hs.IParen _ irule) = toNames irule+  toNames (Hs.IRule _ _mtvbs _mcxt mihd) = toNames mihd+instance ToNames (Hs.InstHead l) where+  toNames (Hs.IHCon _ n) = [toName n]+  toNames (Hs.IHInfix _ _ n) = [toName n]+  toNames (Hs.IHParen _ h) = toNames h+  toNames (Hs.IHApp _ h _) = toNames h++instance ToCxt (Hs.InstRule l) where+  toCxt (Hs.IRule _ _ cxt _) = toCxt cxt+  toCxt (Hs.IParen _ irule) = toCxt irule++instance ToCxt (Hs.Context l) where+  toCxt x = case x of+              Hs.CxEmpty _ -> []+              Hs.CxSingle _ x' -> [toPred x']+              Hs.CxTuple _ xs -> fmap toPred xs++instance ToType (Hs.InstRule l) where+    toType (Hs.IRule _ _ _ h) = toType h+    toType (Hs.IParen _ irule) = toType irule++instance ToType (Hs.InstHead l) where+    toType (Hs.IHCon _ qn) = toType qn+    toType (Hs.IHInfix _ typ qn) = AppT (toType typ) (toType qn)+    toType (Hs.IHParen _ hd) = toType hd+    toType (Hs.IHApp _ hd typ) = AppT (toType hd) (toType typ)++qualConDeclToCon :: Hs.QualConDecl l -> Con+qualConDeclToCon (Hs.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl+qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (toTyVars ns)                                                     (toCxt cxt)                                                     (conDeclToCon cdecl)-conDeclToCon :: Hs.ConDecl -> Con-conDeclToCon (Hs.ConDecl n tys)++instance ToTyVars a => ToTyVars (Maybe a) where+  toTyVars Nothing = []+  toTyVars (Just a) = toTyVars a++instance ToTyVars a => ToTyVars [a] where+  toTyVars = concatMap toTyVars++instance ToTyVars (Hs.TyVarBind l) where+  toTyVars tvb = [toTyVar tvb]++instance ToType (Hs.QName l) where+    toType = ConT . toName++conDeclToCon :: Hs.ConDecl l -> Con+conDeclToCon (Hs.ConDecl _ n tys)   = NormalC (toName n) (map toStrictType tys)-conDeclToCon (Hs.RecDecl n fieldDecls)+conDeclToCon (Hs.RecDecl _ n fieldDecls)   = RecC (toName n) (concatMap convField fieldDecls)   where-    convField (fields, t) =+    convField :: Hs.FieldDecl l -> [VarStrictType]+    convField (Hs.FieldDecl _ ns t) =       let (strict, ty) = toStrictType t-      in map (\field -> (toName field, strict, ty)) fields+      in map (\n' -> (toName n', strict, ty)) ns  -hsMatchesToFunD :: [Hs.Match] -> Dec+hsMatchesToFunD :: [Hs.Match l] -> Dec hsMatchesToFunD [] = FunD (mkName []) []   -- errorish-hsMatchesToFunD xs@(Hs.Match _ n _ _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)+hsMatchesToFunD xs@(Hs.Match _ n _ _ _ : _) = FunD (toName n) (fmap hsMatchToClause xs)  -hsMatchToClause :: Hs.Match -> Clause-hsMatchToClause (Hs.Match _ _ ps _ rhs bnds) = Clause+hsMatchToClause :: Hs.Match l -> 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+hsRhsToBody :: Hs.Rhs l -> Body+hsRhsToBody (Hs.UnGuardedRhs _ e) = NormalB (toExp e)+hsRhsToBody (Hs.GuardedRhss _ hsgrhs) = let fromGuardedB (GuardedB a) = a                                       in GuardedB . concat                                           . fmap (fromGuardedB . hsGuardedRhsToBody)                                               $ hsgrhs   -hsGuardedRhsToBody :: Hs.GuardedRhs -> Body+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@@ -587,35 +682,35 @@   -hsStmtToGuard :: Hs.Stmt -> Guard+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 (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+instance ToDecs (Hs.InstDecl l) where+  toDecs (Hs.InsDecl _ decl) = toDecs decl   toDecs d              = todo "toDec" d  -- * ToDecs HsDecl HsBinds -instance ToDecs Hs.Decl where+instance ToDecs (Hs.Decl l) 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) =+  toDecs (Hs.InfixDecl l assoc Nothing ops) =+      toDecs (Hs.InfixDecl l assoc (Just 9) ops)+  toDecs (Hs.InfixDecl _ assoc (Just fixity) ops) =     map (\op -> InfixD (Fixity fixity dir) (toName op)) ops    where     dir = case assoc of-      Hs.AssocNone -> InfixN-      Hs.AssocLeft -> InfixL-      Hs.AssocRight -> InfixR-#endif+      Hs.AssocNone _ -> InfixN+      Hs.AssocLeft _ -> InfixL+      Hs.AssocRight _ -> InfixR    toDecs a = [toDec a] @@ -632,14 +727,5 @@  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-  -----------------------------------------------------------------------------

@@ -7,7 +7,7 @@   Portability :  portable (template-haskell)    This module is exported for backwards-compatibility purposes.-  All it does is re-export the instances defined in +  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