haskell-src-meta 0.3 → 0.4

raw patch · 6 files changed

+47/−247 lines, 6 filesdep −containersdep ~haskell-src-extsdep ~sybPVP ok

version bump matches the API change (PVP)

Dependencies removed: containers

Dependency ranges changed: haskell-src-exts, syb

API changes (from Hackage documentation)

Files

• haskell-src-meta.cabal +3/−6
• src/Language/Haskell/Meta.hs +3/−3
• src/Language/Haskell/Meta/Parse.hs +1/−1
• src/Language/Haskell/Meta/Syntax.hs +0/−19
• src/Language/Haskell/Meta/Syntax/Translate.hs +40/−44
• src/Language/Haskell/Meta/Syntax/Vars.hs +0/−174

@@ -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

@@ -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()

@@ -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

@@ -1,19 +0,0 @@--{- |-  Module      :  Language.Haskell.Meta.Syntax-  Copyright   :  (c) Matt Morrow 2008-  License     :  BSD3-  Maintainer  :  Matt Morrow <mjm2002@gmail.com>-  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--

@@ -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)]   -----------------------------------------------------------------------------

@@ -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 <mjm2002@gmail.com>-  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--------------------------------------------------------------------------------