diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +0.6.0.7 -> 0.6.0.8: +- Move to HSE 1.16 + 0.6.0.6 -> 0.6.0.7: - Fix compilation oops diff --git a/haskell-src-meta.cabal b/haskell-src-meta.cabal --- a/haskell-src-meta.cabal +++ b/haskell-src-meta.cabal @@ -1,5 +1,5 @@ name: haskell-src-meta -version: 0.6.0.7 +version: 0.6.0.8 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -8,7 +8,7 @@ author: Matt Morrow copyright: (c) Matt Morrow maintainer: Ben Millwood -bug-reports: https://github.com/benmachine/haskell-src-meta/issues +bug-reports: https://github.com/bmillwood/haskell-src-meta/issues stability: experimental tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.2 synopsis: Parse source to template-haskell abstract syntax. @@ -19,7 +19,7 @@ library build-depends: base >= 4.2 && < 4.8, - haskell-src-exts == 1.15.*, + haskell-src-exts == 1.16.*, pretty >= 1.0 && < 1.2, syb >= 0.1 && < 0.5, th-orphans >= 0.5 && < 0.9 @@ -49,5 +49,5 @@ source-repository head type: git - location: git://github.com/benmachine/haskell-src-meta.git + location: git://github.com/bmillwood/haskell-src-meta.git diff --git a/src/Language/Haskell/Meta/Syntax/Translate.hs b/src/Language/Haskell/Meta/Syntax/Translate.hs --- a/src/Language/Haskell/Meta/Syntax/Translate.hs +++ b/src/Language/Haskell/Meta/Syntax/Translate.hs @@ -171,16 +171,15 @@ instance ToPat Hs.Pat where toPat (Hs.PVar n) = VarP (toName n) - toPat (Hs.PLit l) + toPat (Hs.PLit Hs.Signless l) = LitP (toLit l) - toPat (Hs.PNeg (Hs.PLit 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.PNeg p) = nonsense "toPat" "negating non-literal" p #if MIN_VERSION_template_haskell(2,7,0) toPat (Hs.PInfixApp p n q) = UInfixP (toPat p) (toName n) (toPat q) #else @@ -246,9 +245,7 @@ toExp (Hs.Let bs e) = LetE (hsBindsToDecs 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 convert ifs) - where - convert (Hs.IfAlt cond e) = (NormalG (toExp cond), toExp e) + toExp (Hs.MultiIf ifs) = MultiIfE (map toGuard ifs) #else toExp e@Hs.MultiIf{} = noTHyet "toExp" "2.8.0" e #endif @@ -285,19 +282,18 @@ toMatch :: Hs.Alt -> Match -toMatch (Hs.Alt _ p galts ds) = Match (toPat p) (toBody galts) (toDecs ds) +toMatch (Hs.Alt _ p rhs ds) = Match (toPat p) (toBody rhs) (toDecs ds) -toBody :: Hs.GuardedAlts -> Body -toBody (Hs.UnGuardedAlt e) = NormalB $ toExp e -toBody (Hs.GuardedAlts alts) = GuardedB $ do - Hs.GuardedAlt _ stmts e <- alts - let +toBody :: Hs.Rhs -> Body +toBody (Hs.UnGuardedRhs e) = NormalB $ toExp e +toBody (Hs.GuardedRhss rhss) = GuardedB $ map toGuard rhss + +toGuard (Hs.GuardedRhs _ stmts e) = (g, toExp e) + where g = case map toStmt stmts of [NoBindS x] -> NormalG x xs -> PatG xs - return (g, toExp e) -toGuard (Hs.GuardedAlt _ ([Hs.Qualifier e1]) e2) = (NormalG $ toExp e1,toExp e2) ----------------------------------------------------------------------------- @@ -360,7 +356,7 @@ #if MIN_VERSION_template_haskell(2,6,0) Hs.Unboxed -> UnboxedTupleT #else - Hs.Unboxed -> noTHyet "toType TyTuple" "2.6.0" (Hs.TyTuple b ts) + Hs.Unboxed -> noTHyet "toType" "2.6.0" (Hs.TyTuple b ts) #endif toType (Hs.TyApp a b) = AppT (toType a) (toType b) toType (Hs.TyVar n) = VarT (toName n) @@ -369,10 +365,19 @@ -- XXX: need to wrap the name in parens! toType (Hs.TyInfix a o b) = AppT (AppT (ConT (toName o)) (toType a)) (toType b) toType (Hs.TyKind t k) = SigT (toType t) (toKind k) + toType t@Hs.TyBang{} = + nonsense "toType" "type cannot have strictness annotations in this context" t +toStrictType :: Hs.Type -> StrictType +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) + (.->.) :: Type -> Type -> Type a .->. b = AppT (AppT ArrowT a) b @@ -407,11 +412,6 @@ hsBindsToDecs a@Hs.IPBinds{} = noTH "hsBindsToDecs" a -hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type) -hsBangTypeToStrictType (Hs.BangedTy t) = (IsStrict, toType t) -hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t) - - instance ToDec Hs.Decl where toDec (Hs.TypeDecl _ n ns t) = TySynD (toName n) (fmap toTyVar ns) (toType t) @@ -466,13 +466,17 @@ = FamilyD DataFam (toName n) (fmap toTyVar ns) (fmap toKind k) toDec a@(Hs.FunBind mtchs) = hsMatchesToFunD mtchs - toDec (Hs.PatBind _ p tM rhs bnds) = ValD ((maybe id - (flip SigP . toType) - tM) (toPat p)) + toDec (Hs.PatBind _ p rhs bnds) = ValD (toPat p) (hsRhsToBody rhs) (hsBindsToDecs bnds) - toDec (Hs.InstDecl _ cxt qname ts ids) = InstanceD + toDec i@(Hs.InstDecl _ (Just overlap) _ _ _ _ _) = + noTH "toDec" (overlap, i) + + -- the 'vars' bit seems to be for: instance forall a. C (T a) where ... + -- TH's own parser seems to flat-out ignore them, and honestly I can't see + -- that it's obviously wrong to do so. + toDec (Hs.InstDecl _ Nothing _vars cxt qname ts ids) = InstanceD (toCxt cxt) (foldl AppT (ConT (toName qname)) (map toType ts)) (toDecs ids) @@ -511,19 +515,13 @@ (conDeclToCon cdecl) conDeclToCon :: Hs.ConDecl -> Con conDeclToCon (Hs.ConDecl n tys) - = NormalC (toName n) (fmap bangToStrictType tys) -conDeclToCon (Hs.RecDecl n lbls) - = RecC (toName n) (concatMap (uncurry bangToVarStrictTypes) lbls) - - -bangToVarStrictTypes :: [Hs.Name] -> Hs.BangType -> [VarStrictType] -bangToVarStrictTypes ns t = let (a,b) = bangToStrictType t - in fmap (\n->(toName n,a,b)) ns - -bangToStrictType :: Hs.BangType -> StrictType -bangToStrictType (Hs.BangedTy t) = (IsStrict, toType t) -bangToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t) -bangToStrictType (Hs.UnpackedTy t) = (IsStrict, toType t) + = NormalC (toName n) (map toStrictType tys) +conDeclToCon (Hs.RecDecl n fieldDecls) + = RecC (toName n) (concatMap convField fieldDecls) + where + convField (fields, t) = + let (strict, ty) = toStrictType t + in map (\field -> (toName field, strict, ty)) fields hsMatchesToFunD :: [Hs.Match] -> Dec