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.3 +version: 0.4 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -18,17 +18,14 @@ library build-depends: base >= 4.1 && < 4.4, - containers >= 0.2 && < 0.5, - haskell-src-exts >= 1.6 && < 1.10, + haskell-src-exts >= 1.6 && < 1.11, template-haskell >= 2.3 && < 2.6, pretty == 1.0.*, - syb >= 0.1 && < 0.3, + syb >= 0.1 && < 0.4, th-lift == 0.5.* hs-source-dirs: src exposed-modules: Language.Haskell.Meta Language.Haskell.Meta.Parse - Language.Haskell.Meta.Syntax - Language.Haskell.Meta.Syntax.Vars Language.Haskell.Meta.Syntax.Translate Language.Haskell.TH.Instances.Lift Language.Haskell.Meta.Utils diff --git a/src/Language/Haskell/Meta.hs b/src/Language/Haskell/Meta.hs --- a/src/Language/Haskell/Meta.hs +++ b/src/Language/Haskell/Meta.hs @@ -9,10 +9,10 @@ -} module Language.Haskell.Meta ( - module Language.Haskell.Meta.Parse - , module Language.Haskell.Meta.Syntax + module Language.Haskell.Meta.Parse, + module Language.Haskell.Meta.Syntax.Translate ) where import Language.Haskell.Meta.Parse -import Language.Haskell.Meta.Syntax +import Language.Haskell.Meta.Syntax.Translate import Language.Haskell.TH.Instances.Lift() diff --git a/src/Language/Haskell/Meta/Parse.hs b/src/Language/Haskell/Meta/Parse.hs --- a/src/Language/Haskell/Meta/Parse.hs +++ b/src/Language/Haskell/Meta/Parse.hs @@ -11,7 +11,7 @@ module Language.Haskell.Meta.Parse where import Language.Haskell.TH.Syntax -import Language.Haskell.Meta.Syntax +import Language.Haskell.Meta.Syntax.Translate import qualified Language.Haskell.Exts.Syntax as Hs import Language.Haskell.Exts.Annotated.Fixity import Language.Haskell.Exts.Extension diff --git a/src/Language/Haskell/Meta/Syntax.hs b/src/Language/Haskell/Meta/Syntax.hs deleted file mode 100644 --- a/src/Language/Haskell/Meta/Syntax.hs +++ /dev/null @@ -1,19 +0,0 @@ - -{- | - Module : Language.Haskell.Meta.Syntax - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow - Stability : experimental - Portability : portable (template-haskell) --} - -module Language.Haskell.Meta.Syntax ( - module Language.Haskell.Meta.Syntax.Vars - , module Language.Haskell.Meta.Syntax.Translate -) where - -import Language.Haskell.Meta.Syntax.Vars -import Language.Haskell.Meta.Syntax.Translate - - 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 @@ -31,15 +31,22 @@ class ToStmt a where toStmt :: a -> Stmt class ToLoc a where toLoc :: a -> Loc +-- for error messages +moduleName = "Language.Haskell.Meta.Syntax.Translate" -errorMsg :: (Typeable a) => String -> a -> String -errorMsg fun a = concat - [ fun,": " - , show . typeRepTyCon . typeOf $ a - , " not (yet?) implemented" - ] +-- When to use each of these isn't always clear: prefer 'todo' if unsure. +noTH :: Show e => String -> e -> a +noTH fun thing = error . concat $ [moduleName, ".", fun, + ": no TH representation for: ", show thing] +todo :: Show e => String -> e -> a +todo fun thing = error . concat $ [moduleName, ".", fun, + ": not implemented: ", show thing] +nonsense :: Show e => String -> String -> e -> a +nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun, + ": nonsensical: ", inparticular, ": ", show thing] + ----------------------------------------------------------------------------- @@ -156,7 +163,14 @@ ghci> parseHsPat "-2" Right (HsPParen (HsPNeg (HsPLit (HsInt 2)))) -} - toPat (Hs.PNeg p) = error "toPat: HsPNeg not supported" + toPat (Hs.PNeg (Hs.PLit 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 toPat (Hs.PInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q) toPat (Hs.PApp n ps) = ConP (toName n) (fmap toPat ps) toPat (Hs.PTuple ps) = TupP (fmap toPat ps) @@ -168,11 +182,13 @@ toPat (Hs.PWildCard) = WildP toPat (Hs.PIrrPat p) = TildeP (toPat p) toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t) - toPat (Hs.PRPat rps) = error "toPat: HsRPat not supported" - toPat (Hs.PXTag _ _ _ pM p) = error "toPat: HsPXTag not supported" - toPat (Hs.PXETag _ _ _ pM) = error "toPat: HsPXETag not supported" - toPat (Hs.PXPcdata _) = error "toPat: HsPXPcdata not supported" - toPat (Hs.PXPatTag p) = error "toPat: HsPXPatTag not supported" + -- regular pattern + toPat p@Hs.PRPat{} = noTH "toPat" p + -- XML stuff + toPat p@Hs.PXTag{} = noTH "toPat" p + toPat p@Hs.PXETag{} = noTH "toPat" p + toPat p@Hs.PXPcdata{} = noTH "toPat" p + toPat p@Hs.PXPatTag{} = noTH "toPat" p #if MIN_VERSION_template_haskell(2,4,0) toPat (Hs.PBangPat p) = BangP (toPat p) #endif /* MIN_VERSION_template_haskell(2,4,0) */ @@ -233,7 +249,6 @@ -- HsListComp HsExp [HsStmt] -- toExp (HsListComp e ss) = CompE -- NEED: a way to go e -> Stmt - toExp a@(Hs.ListComp e ss) = error $ errorMsg "toExp" a {- HsVarQuote HsQName | HsTypQuote HsQName | HsBracketExp HsBracket @@ -244,15 +259,10 @@ | HsTypeBracket HsType | HsDeclBracket [HsDecl] data HsSplice = HsIdSplice String | HsParenSplice HsExp -} - toExp (Hs.SpliceExp spl) = toExp spl toExp (Hs.Case e alts) = CaseE (toExp e) (map toMatch alts) - toExp e = error $ errorMsg "toExp" e + toExp e = todo "toExp" e -instance ToExp Hs.Splice where - toExp (Hs.IdSplice s) = VarE (toName s) - toExp (Hs.ParenSplice e) = toExp e - toMatch :: Hs.Alt -> Match toMatch (Hs.Alt _ p galts ds) = Match (toPat p) (toBody galts) (toDecs ds) @@ -328,8 +338,8 @@ toKind Hs.KindStar = StarK toKind (Hs.KindFn k1 k2) = ArrowK (toKind k1) (toKind k2) toKind (Hs.KindParen kp) = toKind kp -toKind Hs.KindBang = error "toKind: HsKindBang not supported" -toKind (Hs.KindVar _) = error "toKind: HsKindVar not supported" +toKind k@Hs.KindBang = noTH "toKind" k +toKind k@Hs.KindVar{} = noTH "toKind" k #endif /* !MIN_VERSION_template_haskell(2,4,0) */ #if MIN_VERSION_template_haskell(2,4,0) @@ -380,12 +390,12 @@ 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 a@(Hs.IParam _ _) = error $ errorMsg "toPred" a + toPred a@Hs.IParam{} = noTH "toCxt" a #else /* !MIN_VERSION_template_haskell(2,4,0) */ toPred (Hs.ClassA n ts) = foldAppT (ConT (toName n)) (fmap toType ts) toPred (Hs.InfixA t1 n t2) = foldAppT (ConT (toName n)) (fmap toType [t1, t2]) - toPred a@(Hs.EqualP _ _) = error $ errorMsg "toPred" a - toPred a@(Hs.IParam _ _) = error $ errorMsg "toPred" a + toPred a@Hs.EqualP{} = noTH "toCxt" a + toPred a@Hs.IParam{} = noTH "toCxt" a #endif /* !MIN_VERSION_template_haskell(2,4,0) */ foldAppT :: Type -> [Type] -> Type @@ -408,7 +418,7 @@ -- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind] hsBindsToDecs :: Hs.Binds -> [Dec] hsBindsToDecs (Hs.BDecls ds) = fmap toDec ds -hsBindsToDecs a@(Hs.IPBinds ipbs) = error $ errorMsg "hsBindsToDecs" a +hsBindsToDecs a@Hs.IPBinds{} = noTH "hsBindsToDecs" a -- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp @@ -447,8 +457,9 @@ (fmap qualConDeclToCon qcds) (fmap (toName . fst) qns) Hs.NewType -> let qcd = case qcds of - x:_ -> x - _ -> error "toDec: Newtype has no constructors!" + [x] -> x + _ -> nonsense "toDec" ("newtype with " ++ + "wrong number of constructors") dOrN in NewtypeD (toCxt cxt) (toName n) (fmap toTyVar ns) @@ -477,19 +488,6 @@ -- type VarStrictType = (Name, Strict, Type) - toDec a@(Hs.GDataDecl _ dOrN cxt n ns kM gadtDecs _) = error $ errorMsg "toDec" a - toDec a@(Hs.TypeFamDecl _ n ns kM) = error $ errorMsg "toDec" a - toDec a@(Hs.DataFamDecl _ cxt n ns kM) = error $ errorMsg "toDec" a - toDec a@(Hs.TypeInsDecl _ ta tb) = error $ errorMsg "toDec" a - toDec a@(Hs.DataInsDecl _ dOrN t qcds qns) = error $ errorMsg "toDec" a - toDec a@(Hs.GDataInsDecl _ dOrN t kM gadtDecs _) = error $ errorMsg "toDec" a --- data HsOp = HsVarOp HsName | HsConOp HsName - toDec a@(Hs.InfixDecl _ asst i ops) = error $ errorMsg "toDec" a - toDec a@(Hs.ClassDecl _ cxt n ns funDeps cDecs) = error $ errorMsg "toDec" a - toDec a@(Hs.InstDecl _ cxt qn ts instDecs) = error $ errorMsg "toDec" a - toDec a@(Hs.DerivDecl _ cxt qn ts) = error $ errorMsg "toDec" a - toDec a@(Hs.DefaultDecl _ ts) = error $ errorMsg "toDec" a - toDec a@(Hs.SpliceDecl _ s) = error $ errorMsg "toDec" a -- This type-signature conversion is just wrong. -- Type variables need to be dealt with. /Jonas toDec a@(Hs.TypeSig _ ns t) @@ -517,10 +515,8 @@ tM) (toPat p)) (hsRhsToBody rhs) (hsBindsToDecs bnds) - toDec a@(Hs.ForImp _ cconv safe str n t) = error $ errorMsg "toDec" a - toDec a@(Hs.ForExp _ cconv str n t) = error $ errorMsg "toDec" a - toDec x = error $ "toDec: Untranslatable declaration:" ++ (show x) + toDec x = todo "toDec" x -- data Hs.Decl = ... | Hs.SpliceDecl Hs.SrcLoc Hs.Splice | ... @@ -604,7 +600,7 @@ hsStmtToGuard :: Hs.Stmt -> Guard hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)] hsStmtToGuard (Hs.Qualifier e) = NormalG (toExp e) -hsStmtToGuard a@(Hs.LetStmt _) = error $ errorMsg "hsStmtToGuardExp" a +hsStmtToGuard (Hs.LetStmt bs) = PatG [LetS (hsBindsToDecs bs)] ----------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Meta/Syntax/Vars.hs b/src/Language/Haskell/Meta/Syntax/Vars.hs deleted file mode 100644 --- a/src/Language/Haskell/Meta/Syntax/Vars.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, - MultiParamTypeClasses #-} -{- | - Module : Language.Haskell.Meta.Syntax.Vars - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow - Stability : experimental - Portability : portable (template-haskell) --} - -module Language.Haskell.Meta.Syntax.Vars ( - Vars(..) -) where - -import Data.Set (Set) -import qualified Data.Set as S -import Language.Haskell.TH.Syntax - ------------------------------------------------------------------------------ - - -class Vars e v where - vars :: (Ord v) => e -> Set v - fvs :: (Ord v) => e -> Set v - bvs :: (Ord v) => e -> Set v - vars e = fvs e `S.union` bvs e - fvs e = vars e `S.difference` bvs e - bvs e = vars e `S.difference` fvs e - - -instance (Vars e v) => Vars [e] v where - vars = S.unions . fmap vars - fvs = S.unions . fmap fvs - bvs = S.unions . fmap bvs - - ------------------------------------------------------------------------------ - - -instance Vars Pat Name where - vars (LitP _) = S.empty - vars (VarP n) = S.singleton n - vars (TupP ps) = vars ps - vars (ConP n ps) = n `S.insert` vars ps - vars (InfixP p n q) = n `S.insert` vars [p,q] - vars (TildeP p) = vars p - vars (AsP n p) = n `S.insert` vars p - vars (WildP) = S.empty - vars (RecP n pfs) = (n `S.insert`) . vars . fmap snd $ pfs - vars (ListP ps) = vars ps - vars (SigP p _) = vars p -#if MIN_VERSION_template_haskell(2,4,0) - vars (BangP p) = vars p -#endif /* MIN_VERSION_template_haskell(2,4,0) */ - - bvs (LitP _) = S.empty - bvs (VarP n) = S.singleton n - bvs (TupP ps) = bvs ps - bvs (ConP _ ps) = bvs ps - bvs (InfixP p _ q) = bvs [p,q] - bvs (TildeP p) = bvs p - bvs (AsP n p) = n `S.insert` bvs p - bvs (WildP) = S.empty - bvs (RecP _ pfs) = bvs . fmap snd $ pfs - bvs (ListP ps) = bvs ps - bvs (SigP p _) = bvs p -#if MIN_VERSION_template_haskell(2,4,0) - bvs (BangP p) = bvs p -#endif /* MIN_VERSION_template_haskell(2,4,0) */ - - -instance Vars Range Name where - vars (FromR e) = vars e - vars (FromThenR e f) = vars [e,f] - vars (FromToR e f) = vars [e,f] - vars (FromThenToR e f g) = vars [e,f,g] - fvs (FromR e) = fvs e - fvs (FromThenR e f) = fvs [e,f] - fvs (FromToR e f) = fvs [e,f] - fvs (FromThenToR e f g) = fvs [e,f,g] - - -instance Vars Exp Name where - vars (LamE ps e) = fvs ps `S.union` vars e - vars (LetE ds e) = fvs e `S.union` vars ds - vars e = fvs e - fvs (VarE n) = S.singleton n - fvs (ConE n) = S.singleton n - fvs (LitE _) = S.empty - fvs (AppE a b) = fvs [a,b] - fvs (InfixE aM b cM) = fvs (b : concatMap (maybe [] (:[])) [aM,cM]) - fvs (LamE ps e) = fvs e `S.difference` bvs ps - fvs (TupE es) = fvs es - fvs (CondE e f g) = fvs [e,f,g] - fvs (LetE ds e) = (fvs e `S.union` fvs ds) `S.difference` bvs ds - fvs (CaseE e ms) = fvs e `S.union` fvs ms - fvs (DoE ss) = fvs ss - fvs (CompE ss) = fvs ss - fvs (ArithSeqE r) = fvs r - fvs (ListE xs) = fvs xs - fvs (SigE e _) = fvs e - fvs (RecConE n xs) = (n `S.insert`) . fvs . fmap snd $ xs - fvs (RecUpdE e xs) = fvs . (e:) . fmap snd $ xs - - -instance Vars Match Name where - fvs (Match p b decs) = (fvs b `S.union` fvs decs) - `S.difference` (bvs decs `S.union` bvs p) - - -instance Vars Dec Name where - vars (FunD n cs) = n `S.insert` vars cs - vars (ValD p bdy decs) = - vars p `S.union` vars bdy `S.union` vars decs - vars (ClassD _ _ _ _ decs) = vars decs - vars (InstanceD _ _ decs) = vars decs - vars _ = S.empty - bvs (FunD n _) = S.singleton n - bvs (ValD p _ _) = bvs p - bvs (ClassD _ _ _ _ decs) = bvs decs - bvs (InstanceD _ _ decs) = bvs decs - bvs (SigD n _) = S.singleton n - bvs _ = S.empty - - --- data Clause = Clause [Pat] Body [Dec] -instance Vars Clause Name where - vars (Clause ps bdy decs) = - vars ps `S.union` vars bdy `S.union` vars decs - fvs (Clause ps bdy decs) = - fvs bdy `S.difference` (bvs ps `S.union` bvs decs) - - --- data Body = GuardedB [(Guard, Exp)] | NormalB Exp -instance Vars Body Name where - vars (NormalB e) = vars e - vars (GuardedB xs) = S.unions - . fmap (\(g,e) -> vars g `S.union` vars e) - $ xs - fvs (NormalB e) = fvs e - fvs (GuardedB xs) = S.unions - . fmap (\(g,e) -> fvs e `S.difference` bvs g) - $ xs - - --- data Guard = NormalG Exp | PatG [Stmt] -instance Vars Guard Name where - vars (NormalG e) = vars e - vars (PatG ss) = vars ss - fvs (NormalG e) = fvs e - fvs (PatG ss) = fvs ss - bvs (NormalG e) = bvs e - bvs (PatG ss) = bvs ss - - --- data Stmt = BindS Pat Exp | LetS [Dec] | NoBindS Exp | ParS [[Stmt]] -instance Vars Stmt Name where - vars (BindS p e) = vars p `S.union` vars e - vars (LetS decs) = vars decs - vars (NoBindS e) = vars e - vars (ParS sss) = vars . concat $ sss - fvs (BindS p e) = fvs e `S.difference` bvs p - fvs (LetS decs) = fvs decs - fvs (NoBindS e) = fvs e - fvs (ParS sss) = fvs . concat $ sss - bvs (BindS p e) = bvs p - bvs (LetS decs) = bvs decs - bvs (NoBindS e) = bvs e - bvs (ParS sss) = bvs . concat $ sss - - ------------------------------------------------------------------------------