diff --git a/Data/Derive/BinaryDefer.hs b/Data/Derive/BinaryDefer.hs --- a/Data/Derive/BinaryDefer.hs +++ b/Data/Derive/BinaryDefer.hs @@ -14,7 +14,7 @@ instance (BinaryDefer e, BinaryDefer a) => BinaryDefer (FailList e a) where bothDefer = defer [\ ~(o@Zoro) -> unit Zoro < unit Fail << x1 + ,\ ~(Fial x1) -> unit Fial << x1 ,\ ~(Const x1 x2) -> unit Const << x1 << x2 ] diff --git a/Data/Derive/Foldable.hs b/Data/Derive/Foldable.hs --- a/Data/Derive/Foldable.hs +++ b/Data/Derive/Foldable.hs @@ -17,7 +17,7 @@ test :: FailList instance Foldable (FailList t1) where foldr _ b Zoro = b - foldr _ b (Fail _) = b + foldr _ b (Fial _) = b foldr _f b (Const a1 a2) = _f a1 (Data.Foldable.foldr _f b a2) test :: Sample diff --git a/Data/Derive/Functor.hs b/Data/Derive/Functor.hs --- a/Data/Derive/Functor.hs +++ b/Data/Derive/Functor.hs @@ -20,7 +20,7 @@ test :: FailList instance Functor (FailList t1) where fmap _ Zoro = Zoro - fmap _ (Fail a1) = Fail a1 + fmap _ (Fial a1) = Fial a1 fmap _f (Const a1 a2) = Const (_f a1) (fmap _f a2) test :: State diff --git a/Data/Derive/Traversable.hs b/Data/Derive/Traversable.hs --- a/Data/Derive/Traversable.hs +++ b/Data/Derive/Traversable.hs @@ -18,7 +18,7 @@ instance Traversable (FailList t1) where traverse _f (Zoro) = pure Nil - traverse _f (Fail a1) = pure (Fail a1) + traverse _f (Fial a1) = pure (Fial a1) traverse _f (Const a1 a2) = (Const <$> _f a1) <*> traverse _f a2 instance Traversable Sample where diff --git a/Data/DeriveMain.hs b/Data/DeriveMain.hs new file mode 100644 --- /dev/null +++ b/Data/DeriveMain.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- Needed for Haddock docs + +-- | Use this module to create your own derive program, supporting custom derivations. +-- As an example: +-- +-- @ +-- import "Data.DeriveMain" ('deriveMain') +-- import "Data.Derive.All" ('derivations') +-- import MyProject.MyDerivation (myDerivation) +-- @ +-- +-- @ +-- main :: IO +-- main = 'deriveMain' $ [myDerivation] ++ 'derivations' +-- @ +module Data.DeriveMain(deriveMain) where + +import Derive.Main +import Data.Derive.All(derivations) diff --git a/Derive/Derivation.hs b/Derive/Derivation.hs --- a/Derive/Derivation.hs +++ b/Derive/Derivation.hs @@ -9,7 +9,6 @@ import Data.List import Derive.Utils import Derive.Flags -import Data.Derive.All import Data.Derive.Internal.Derivation import qualified Data.Map as Map @@ -45,16 +44,17 @@ --------------------------------------------------------------------- -- ACTUALLY DERIVE IT -performDerive :: Module -> [Type] -> [String] -performDerive modu = concatMap ((:) "" . f) +performDerive :: [Derivation] -> Module -> [Type] -> [String] +performDerive derivations modu = concatMap ((:) "" . f) where grab = getDecl modu + g = getDerivation derivations f ty = case d ty grab (moduleName modu, grab typ1Name) of Left x -> unsafePerformIO $ let res = msg x in hPutStrLn stderr res >> return ["-- " ++ res] Right x -> concatMap (lines . prettyPrint) x where - d = derivationOp $ getDerivation clsName + d = derivationOp $ g clsName (cls,typ1:_) = fromTyApps ty clsName = prettyPrint cls typ1Name = tyRoot typ1 @@ -71,8 +71,8 @@ f _ = [] -getDerivation :: String -> Derivation -getDerivation = \name -> Map.findWithDefault (error $ "Don't know how to derive type class: " ++ name) name mp +getDerivation :: [Derivation] -> String -> Derivation +getDerivation derivations = \name -> Map.findWithDefault (error $ "Don't know how to derive type class: " ++ name) name mp where mp = Map.fromList $ map (derivationName &&& id) derivations diff --git a/Derive/Flags.hs b/Derive/Flags.hs --- a/Derive/Flags.hs +++ b/Derive/Flags.hs @@ -38,7 +38,7 @@ getFlags = do args <- getArgs case getOpt Permute options args of - (o,n,[] ) | Version `elem` o -> putStrLn "Derive 2.0, (C) Neil Mitchell 2006-2009" >> exitSuccess + (o,n,[] ) | Version `elem` o -> putStrLn "Derive 2.4.* (C) Neil Mitchell 2006-2011" >> exitSuccess | Help `elem` o -> putStr flagInfo >> exitSuccess | otherwise -> do files <- mapM pickFile n; return (o, files) (_,_,errs) -> hPutStr stderr (concat errs ++ flagInfo) >> exitFailure diff --git a/Derive/Main.hs b/Derive/Main.hs new file mode 100644 --- /dev/null +++ b/Derive/Main.hs @@ -0,0 +1,59 @@ + +module Derive.Main(deriveMain) where + +import Language.Haskell +import Data.Derive.All(Derivation) +import Derive.Derivation +import Derive.Generate +import Derive.Test +import Derive.Flags +import Data.List + + +deriveMain :: [Derivation] -> IO () +deriveMain derivations = do + (flags,files) <- getFlags + if Test `elem` flags then + test + else if Generate `elem` flags then + generate + else if null files then + putStr $ "No files specified\n" ++ flagInfo + else + mapM_ (mainFile derivations flags) files + + +mainFile :: [Derivation] -> [Flag] -> FilePath -> IO () +mainFile derivations flags file = do + src <- readFile file + src <- return $ unlines $ filter (not . isPrefixOf "#") $ lines src + let parse = fromParseResult . parseFileContentsWithMode defaultParseMode{parseFilename=file,extensions=extension} + real = parse src + mine = parse $ uncomment src + flags <- return $ foldl addFlags flags + [(sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine] + let res = performDerive derivations mine $ wantDerive flags real mine + writeDerive file (moduleName mine) flags res + + +uncomment :: String -> String +uncomment ('{':'-':'!':xs) = ' ':' ':' ':uncomment xs +uncomment ('!':'-':'}':xs) = ' ':' ':' ':uncomment xs +uncomment (x:xs) = x:uncomment xs +uncomment [] = [] + + +-- Taken from HLint, update occasionally +extension = + [OverlappingInstances,UndecidableInstances,IncoherentInstances,RecursiveDo + ,ParallelListComp,MultiParamTypeClasses,NoMonomorphismRestriction,FunctionalDependencies + ,Rank2Types,RankNTypes,PolymorphicComponents,ExistentialQuantification,ScopedTypeVariables + ,ImplicitParams,FlexibleContexts,FlexibleInstances,EmptyDataDecls + ,KindSignatures,BangPatterns,TypeSynonymInstances,TemplateHaskell + ,ForeignFunctionInterface,Generics,NoImplicitPrelude,NamedFieldPuns,PatternGuards + ,GeneralizedNewtypeDeriving,ExtensibleRecords,RestrictedTypeSynonyms,HereDocuments + ,MagicHash,TypeFamilies,StandaloneDeriving,UnicodeSyntax,PatternSignatures,UnliftedFFITypes + ,LiberalTypeSynonyms,TypeOperators,RecordWildCards,RecordPuns,DisambiguateRecordFields + ,OverloadedStrings,GADTs,MonoPatBinds,RelaxedPolyRec,ExtendedDefaultRules,UnboxedTuples + ,DeriveDataTypeable,ConstrainedClassMethods,PackageImports,ImpredicativeTypes + ,NewQualifiedOperators,PostfixOperators,QuasiQuotes,ViewPatterns] diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,58 +1,9 @@ module Main(main) where -import Language.Haskell -import Derive.Derivation -import Derive.Generate -import Derive.Test -import Derive.Flags -import Data.List +import Data.Derive.All +import Data.DeriveMain main :: IO () -main = do - (flags,files) <- getFlags - if Test `elem` flags then - test - else if Generate `elem` flags then - generate - else if null files then - putStr $ "No files specified\n" ++ flagInfo - else - mapM_ (mainFile flags) files - - -mainFile :: [Flag] -> FilePath -> IO () -mainFile flags file = do - src <- readFile file - src <- return $ unlines $ filter (not . isPrefixOf "#") $ lines src - let parse = fromParseResult . parseFileContentsWithMode defaultParseMode{parseFilename=file,extensions=extension} - real = parse src - mine = parse $ uncomment src - flags <- return $ foldl addFlags flags - [(sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine] - let res = performDerive mine $ wantDerive flags real mine - writeDerive file (moduleName mine) flags res - - -uncomment :: String -> String -uncomment ('{':'-':'!':xs) = ' ':' ':' ':uncomment xs -uncomment ('!':'-':'}':xs) = ' ':' ':' ':uncomment xs -uncomment (x:xs) = x:uncomment xs -uncomment [] = [] - - --- Taken from HLint, update occasionally -extension = - [OverlappingInstances,UndecidableInstances,IncoherentInstances,RecursiveDo - ,ParallelListComp,MultiParamTypeClasses,NoMonomorphismRestriction,FunctionalDependencies - ,Rank2Types,RankNTypes,PolymorphicComponents,ExistentialQuantification,ScopedTypeVariables - ,ImplicitParams,FlexibleContexts,FlexibleInstances,EmptyDataDecls - ,KindSignatures,BangPatterns,TypeSynonymInstances,TemplateHaskell - ,ForeignFunctionInterface,Generics,NoImplicitPrelude,NamedFieldPuns,PatternGuards - ,GeneralizedNewtypeDeriving,ExtensibleRecords,RestrictedTypeSynonyms,HereDocuments - ,MagicHash,TypeFamilies,StandaloneDeriving,UnicodeSyntax,PatternSignatures,UnliftedFFITypes - ,LiberalTypeSynonyms,TypeOperators,RecordWildCards,RecordPuns,DisambiguateRecordFields - ,OverloadedStrings,GADTs,MonoPatBinds,RelaxedPolyRec,ExtendedDefaultRules,UnboxedTuples - ,DeriveDataTypeable,ConstrainedClassMethods,PackageImports,ImpredicativeTypes - ,NewQualifiedOperators,PostfixOperators,QuasiQuotes,ViewPatterns] +main = deriveMain derivations diff --git a/derive.cabal b/derive.cabal --- a/derive.cabal +++ b/derive.cabal @@ -1,7 +1,7 @@ Cabal-Version: >= 1.6 Build-Type: Default Name: derive -Version: 2.4.2 +Version: 2.5.1 build-type: Simple Copyright: 2006-2011, Neil Mitchell Maintainer: ndmitchell@gmail.com @@ -23,25 +23,17 @@ Executable derive Main-Is: Main.hs - Other-Modules: - Derive.Derivation - Derive.Flags - Derive.Generate - Derive.Test - Derive.Utils - - Build-Depends: - directory, process, bytestring - Library Build-Depends: base == 4.*, filepath, syb, template-haskell, containers, pretty, + directory, process, bytestring, haskell-src-exts >= 1.9 && < 1.11, transformers == 0.2.*, uniplate >= 1.5 && < 1.7 Exposed-Modules: + Data.DeriveMain Data.DeriveTH Data.DeriveDSL Data.Derive.All @@ -105,3 +97,9 @@ Other-Modules: Data.Derive.Internal.Instance Data.Derive.Internal.Traversal + Derive.Main + Derive.Derivation + Derive.Flags + Derive.Generate + Derive.Test + Derive.Utils