DTC 1.0.1 → 1.1.0

raw patch · 6 files changed

+173/−86 lines, 6 filesdep +haskell-src-extsdep −haskell-srcPVP ok

version bump matches the API change (PVP)

Dependencies added: haskell-src-exts

Dependencies removed: haskell-src

API changes (from Hackage documentation)

Files

• DTC.cabal +9/−7
• Language/Haskell/DTC.hs +6/−5
• Language/Haskell/DTC/Class.hs +98/−52
• Language/Haskell/DTC/DataInfo.hs +34/−0
• Language/Haskell/DTC/Mod.hs +16/−9
• Language/Haskell/DTC/Parser.hs +10/−13

@@ -1,5 +1,5 @@ Name:           DTC
-Version:        1.0.1
+Version:        1.1.0
 Author:         Daniel Diaz
 Homepage:       http://ddiaz.asofilak.es/packages/DTC
 License:        BSD3
@@ -9,20 +9,22 @@ Synopsis:       Data To Class transformation.
 Description:    Transform data declarations to class definitions.
                 .
-                The way is explained in /Data Declarations to Class Definitions/.
-                You can find more information in the homepage of the package.
+                The way is explained in /Data Declarations to Class Definitions/ (see the homepage).
                 .
                 Changes from last version:
                 .
-                * Modified some documentation.
+                * Now @DTC@ uses @haskell-src-exts@ instead of @haskell-src@.
                 .
-                * Fixed a non-exhaustive pattern matching error in @dataToClassWith@.
+                * New module: @DataInfo@.
+                .
+                * The @Maybe@ example included (in "Language.Haskell.DTC.Class" module).
 Build-type:     Simple
 Build-depends:  base == 4.*
-              , haskell-src
+              , haskell-src-exts
 Cabal-version:  >= 1.6
 Exposed-modules: 
            Language.Haskell.DTC
          , Language.Haskell.DTC.Parser
          , Language.Haskell.DTC.Mod
-         , Language.Haskell.DTC.Class+         , Language.Haskell.DTC.Class
+         , Language.Haskell.DTC.DataInfo

@@ -1,18 +1,19 @@ 
 -- | Main module of @DTC@.
 module Language.Haskell.DTC
-   ( -- * Export of @DTC@ modules.
+   ( -- * Export of @DTC@ modules
      module Language.Haskell.DTC.Parser
    , module Language.Haskell.DTC.Mod
    , module Language.Haskell.DTC.Class
-     -- * Re-export "Language.Haskell.Pretty"
-   , module Language.Haskell.Pretty
-     -- * Extra functions
+   , module Language.Haskell.DTC.DataInfo
+     -- * Re-export "Language.Haskell.Exts.Pretty"
+   , module Language.Haskell.Exts.Pretty
      ) where
 
 import Language.Haskell.DTC.Parser
 import Language.Haskell.DTC.Mod
 import Language.Haskell.DTC.Class
+import Language.Haskell.DTC.DataInfo
 
-import Language.Haskell.Pretty
+import Language.Haskell.Exts.Pretty
 

@@ -1,97 +1,143 @@ 
 -- | Class definition from a data declaration.
 module Language.Haskell.DTC.Class
-   ( dataToClassWith
+   ( -- * Functions
+     dataToClassWith
    , dataToClass
+     -- * Example
+     -- $example
      ) where
 
 import Data.Char
 import Data.Maybe
-import Language.Haskell.Syntax
+import Language.Haskell.Exts
 
 import Language.Haskell.DTC.Mod
 
+----------------------------------------------------------------------------------------
+{- $example
+Let's see an example of how you can transform all data declarations in a module to class definitions.
+
+Let the following module (Maybe.hs):
+
+> module MaybeExample where
+>
+> data Maybe a = Just a | Nothing
+
+It contains the data declaration of the 'Maybe' type. Now, if we write:
+
+> import Language.Haskell.DTC
+>
+> main = do -- Parse the code.
+>           m <- parseModuleWithSrc "Maybe.hs" defaultParseMode
+>           -- Modify declarations with dataToClassWith.
+>           let m' = modifyHsDecls (map (dataToClassWith "m")) m
+>           -- Write the pretty-printed output.
+>           writeFile "MaybeC.hs" (prettyPrint m')
+
+It produces the following output (in MaybeC.hs):
+
+> module MaybeExample where
+>
+> class Maybe m where
+>
+>         just :: a -> m a
+>
+>         fromJust :: m a -> a
+>
+>         nothing :: m a
+
+-}
+----------------------------------------------------------------------------------------
+
 -- | Transform a data declaration to a class definition.
 -- The 'String' argument will be the name of the type variable of the class definition.
-dataToClassWith :: String -> HsDecl -> HsDecl
-dataToClassWith str (HsDataDecl loc ctx x_T xs_v xs_C xs_Q)
+dataToClassWith :: String -> Decl -> Decl
+dataToClassWith str (DataDecl loc _ ctx x_T xs_v xs_C _)
       = let methods = concatMap (method str xs_v x_T) xs_C
-        in  HsClassDecl loc ctx x_T [HsIdent str] methods
+        in  ClassDecl loc ctx x_T [UnkindedVar $ Ident str] [] methods
 dataToClassWith _ d = d
 
 -- | Transform a data declaration to a class definition.
 -- Equivalent to @dataToClassWith \"t\"@.
-dataToClass :: HsDecl -> HsDecl
+dataToClass :: Decl -> Decl
 dataToClass = dataToClassWith "t"
 
-(->>) :: HsType -> HsType -> HsType
-t1 ->> t2 = HsTyFun t1 t2
+(->>) :: Type -> Type -> Type
+t1 ->> t2 = TyFun t1 t2
 
-(.>>) :: HsType -> HsType -> HsType
-t1 .>> t2 = HsTyApp t1 t2
+(.>>) :: Type -> Type -> Type
+t1 .>> t2 = TyApp t1 t2
 
-hsTyTuple :: [HsType] -> HsType
+hsTyTuple :: [Type] -> Type
 hsTyTuple [t] = t
-hsTyTuple xs  = HsTyTuple xs
+hsTyTuple xs  = TyTuple Boxed xs
 
-replaceType :: HsName -> String -> HsType -> HsType
-replaceType name new (HsTyFun t1 t2) = HsTyFun (replaceType name new t1) (replaceType name new t2)
-replaceType name new (HsTyTuple xs)  = HsTyTuple $ map (replaceType name new) xs
-replaceType name new (HsTyApp t1 t2) = HsTyApp (replaceType name new t1) (replaceType name new t2)
-replaceType name new (HsTyVar name') = if name == name' then HsTyVar $ HsIdent new
-                                                        else HsTyVar name'
-replaceType name new (HsTyCon qname) =
-    HsTyCon $
+replaceType :: Name -> String -> Type -> Type
+replaceType name new (TyFun t1 t2) = replaceType name new t1 ->> replaceType name new t2
+replaceType name new (TyTuple b xs)  = TyTuple Unboxed $ map (replaceType name new) xs
+replaceType name new (TyApp t1 t2) = replaceType name new t1 .>> replaceType name new t2
+replaceType name new (TyVar name') = if name == name' then TyVar $ Ident new
+                                                      else TyVar name'
+replaceType name new (TyCon qname) =
+    TyCon $
      case qname of
-      Qual m name' -> if name == name' then Qual m $ HsIdent new
+      Qual m name' -> if name == name' then Qual m $ Ident new
                                        else Qual m name'
-      UnQual name' -> if name == name' then UnQual $ HsIdent new
+      UnQual name' -> if name == name' then UnQual $ Ident new
                                        else UnQual name'
       x -> x
+replaceType name new (TyForall m ctx t) = TyForall m ctx $ replaceType name new t
+replaceType name new (TyList t) = TyList $ replaceType name new t
+replaceType name new (TyParen t) = TyParen $ replaceType name new t
+replaceType name new (TyInfix t1 q t2) = TyInfix (replaceType name new t1) q (replaceType name new t2)
+replaceType name new (TyKind t k) = TyKind (replaceType name new t) k
 
-constructor :: String -> [HsName] -> HsName -> HsConDecl -> HsDecl
-constructor str xs_v x_T (HsConDecl loc name xs) =
+constructor :: String -> [TyVarBind] -> Name -> QualConDecl -> ClassDecl
+constructor str xs_v x_T (QualConDecl loc _ _ (ConDecl name xs)) =
     constructor_ str loc name xs_v x_T xs
-constructor str xs_v x_T (HsRecDecl loc name xs) =
+constructor str xs_v x_T (QualConDecl loc _ _ (RecDecl name xs)) =
     constructor_ str loc name xs_v x_T (map snd xs)
 
-constructor_ :: String -> SrcLoc -> HsName -> [HsName]
-                       -> HsName -> [HsBangType] -> HsDecl
+constructor_ :: String -> SrcLoc -> Name -> [TyVarBind]
+                       -> Name -> [BangType] -> ClassDecl
 constructor_ str loc name xs_v x_T xs =
-     HsTypeSig loc [modifyHsName (\(n:ns) -> toLower n : ns) name]
-               (HsQualType [] $
+  ClsDecl $ 
+       TypeSig loc [modifyHsName (\(n:ns) -> toLower n : ns) name]
+               (TyForall Nothing [] $
                  foldr (->>)
                        (foldl (.>>)
-                              (HsTyVar $ HsIdent str)
-                              (map HsTyVar xs_v) )
+                              (TyVar $ Ident str)
+                              (map (TyVar . tyVarName) xs_v) )
                        (map (replaceType x_T str . unBangType) xs)
                 )
 
-deconstructor :: String -> [HsName] -> HsName -> HsConDecl -> [HsDecl]
-deconstructor str xs_v x_T (HsConDecl loc name xs) =
+deconstructor :: String -> [TyVarBind] -> Name -> QualConDecl -> [ClassDecl]
+deconstructor str xs_v x_T (QualConDecl loc _ _ (ConDecl name xs)) =
     if length xs > 0
-       then [ HsTypeSig loc [modifyHsName ("from"++) name]
-                        (HsQualType [] $
-                          foldl (.>>)
-                                (HsTyVar $ HsIdent str)
-                                (map HsTyVar xs_v)
-                          ->>
-                          (hsTyTuple $ map (replaceType x_T str . unBangType) xs)
-                         )
+       then [ ClsDecl $
+                 TypeSig loc [modifyHsName ("from"++) name]
+                      (TyForall Nothing [] $
+                        foldl (.>>)
+                              (TyVar $ Ident str)
+                              (map (TyVar . tyVarName) xs_v)
+                        ->>
+                        (hsTyTuple $ map (replaceType x_T str . unBangType) xs)
+                       )
              ]
        else [ ]
-deconstructor str xs_v x_T (HsRecDecl loc name xs) =
-    map (\(ys,t) -> 
-     HsTypeSig loc [head ys]
-               (HsQualType [] $
-                 foldl (.>>)
-                       (HsTyVar $ HsIdent str)
-                       (map HsTyVar xs_v)
-                 ->>
-                 (replaceType x_T str $ unBangType t)
-                )
+deconstructor str xs_v x_T (QualConDecl loc _ _ (RecDecl name xs)) =
+    map (\(ys,t) -> ClsDecl $
+     TypeSig loc [head ys]
+             (TyForall Nothing [] $
+               foldl (.>>)
+                     (TyVar $ Ident str)
+                     (map (TyVar . tyVarName) xs_v)
+               ->>
+               (replaceType x_T str $ unBangType t)
+              )
          ) xs
 
-method :: String -> [HsName] -> HsName -> HsConDecl -> [HsDecl]
+method :: String -> [TyVarBind] -> Name -> QualConDecl -> [ClassDecl]
 method str xs x_T dec = constructor str xs x_T dec : deconstructor str xs x_T dec
 

@@ -0,0 +1,34 @@+
+module Language.Haskell.DTC.DataInfo
+     ( DataInfo (..)
+     , dataInfo
+     , moduleDataInfo
+       ) where
+
+import Language.Haskell.Exts
+import Data.Maybe
+
+import Language.Haskell.DTC.Mod
+
+-- | Information about names in a data declaration.
+data DataInfo =
+      DataInfo { dataName  :: Name -- ^ The data type name.
+               , consList  :: [ (Name , Int) ] -- ^ Ordinary constructor names, and their number of arguments.
+               , rconsList :: [ (Name , [Name]) ] -- ^ Record constructor names and their field names.
+                 } deriving Show
+
+-- | Extract a 'DataInfo' from a declaration. Returns 'Nothing' if the argument is not a data declaration.
+dataInfo :: Decl -> Maybe DataInfo
+dataInfo (DataDecl _ _ _ name _ xs _) = Just $
+    DataInfo name (mapMaybe (consName . fromConDecl) xs) (mapMaybe (rconsName . fromConDecl) xs)
+      where
+       fromConDecl (QualConDecl _ _ _ x) = x
+       consName (ConDecl n ys) = Just (n , length ys)
+       consName _ = Nothing
+       rconsName (RecDecl n ys) = Just (n , map (head . fst) ys)
+       rconsName _ = Nothing
+dataInfo _ = Nothing
+
+-- | Extract 'DataInfo' from all data declarations in a module.
+moduleDataInfo :: Module -> [DataInfo]
+moduleDataInfo (Module _ _ _ _ _ _ decls) = mapMaybe dataInfo decls

@@ -3,21 +3,28 @@ module Language.Haskell.DTC.Mod
     ( modifyHsDecls
     , unBangType
+    , tyVarName
     , modifyHsName
       ) where
 
-import Language.Haskell.Syntax
+import Language.Haskell.Exts
 
 -- | Lift a function over @[@'HsDecl'@]@ to a function over 'HsModule'.
-modifyHsDecls :: ([HsDecl] -> [HsDecl]) -> (HsModule -> HsModule)
-modifyHsDecls f (HsModule loc m es is decls) = HsModule loc m es is $ f decls
+modifyHsDecls :: ([Decl] -> [Decl]) -> (Module -> Module)
+modifyHsDecls f (Module loc m pr w es is decls) = Module loc m pr w es is $ f decls
 
 -- | Skip a bang in a type.
-unBangType :: HsBangType -> HsType
-unBangType (HsBangedTy x)   = x
-unBangType (HsUnBangedTy x) = x
+unBangType :: BangType -> Type
+unBangType (BangedTy x)   = x
+unBangType (UnBangedTy x) = x
+unBangType (UnpackedTy x) = x
 
+-- | Extract the 'Name' of a 'TyVarBind'.
+tyVarName :: TyVarBind -> Name
+tyVarName (KindedVar n _) = n
+tyVarName (UnkindedVar n) = n
+
 -- | Lift a function over 'String' to a function over 'HsName'.
-modifyHsName :: (String -> String) -> (HsName -> HsName)
-modifyHsName f (HsIdent x) = HsIdent $ f x
-modifyHsName f (HsSymbol x) = HsSymbol $ f x
+modifyHsName :: (String -> String) -> (Name -> Name)
+modifyHsName f (Ident x) = Ident $ f x
+modifyHsName f (Symbol x) = Symbol $ f x

@@ -1,27 +1,24 @@ 
 -- | All you need to parse a module.
 module Language.Haskell.DTC.Parser
-    ( -- * From "Language.Haskell.Parser"
-      ParseResult
-    , HsModule
+    ( -- * From "Language.Haskell.Exts.Parser"
+      ParseResult (..)
+    , Module
+    , ParseMode (..)
+    , defaultParseMode
     , parseModule
+    , parseModuleWithMode
       -- * Extras
-    , parseModuleWithFN
     , parseModuleWithSrc
      ) where
 
-import Language.Haskell.Syntax
-import Language.Haskell.Parser
-
--- | @parseModuleWithFN fileName module@ parse @module@ with a @fileName@ associated.
-parseModuleWithFN :: FilePath -> String -> ParseResult HsModule
-parseModuleWithFN = parseModuleWithMode . ParseMode
+import Language.Haskell.Exts
 
 -- | Parse a module from a source code file. It throws an error if parsing fails.
-parseModuleWithSrc :: FilePath -> IO HsModule
-parseModuleWithSrc fp =
+parseModuleWithSrc :: FilePath -> ParseMode -> IO Module
+parseModuleWithSrc fp pm =
       do str <- readFile fp
-         let r = parseModuleWithFN fp str
+         let r = parseModuleWithMode (pm { parseFilename = fp }) str
          case r of
            ParseOk p -> return p
            ParseFailed loc err -> do fail $ concat [ err