derive-2.5.13/0000755000000000000000000000000012212421520011235 5ustar0000000000000000derive-2.5.13/Setup.hs0000644000000000000000000000005612212421520012672 0ustar0000000000000000import Distribution.Simple main = defaultMain derive-2.5.13/Main.hs0000644000000000000000000000016612212421520012460 0ustar0000000000000000 module Main(main) where import Data.Derive.All import Data.DeriveMain main :: IO () main = deriveMain derivations derive-2.5.13/LICENSE0000644000000000000000000000276412212421520012253 0ustar0000000000000000Copyright Neil Mitchell 2006-2013. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Neil Mitchell nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. derive-2.5.13/derive.htm0000644000000000000000000003354612212421520013240 0ustar0000000000000000 Data.Derive: A User Manual

Data.Derive: A User Manual

by Neil Mitchell

Data.Derive is a library and a tool for deriving instances for Haskell programs. It is designed to work with custom derivations, SYB and Template Haskell mechanisms. The tool requires GHC, but the generated code is portable to all compilers. We see this tool as a competitor to DrIFT.

This document proceeds as follows:

  1. Obtaining and Installing Data.Derive
  2. Supported Derivations
  3. Using the Derive Program
  4. Using Template Haskell Derivations
  5. Writing a New Derivation

Acknowledgements

Thanks to everyone who has submitted patches and given assistance, including: Twan van Laarhoven, Spencer Janssen, Andrea Vezzosi, Samuel Bronson, Joel Raymont, Benedikt Huber, Stefan O'Rear, Robin Green, Bertram Felgenhauer.

Obtaining and Installing Data.Derive

Installation follows the standard pattern of any Haskell library or program, type cabal update to update your local hackage database, then cabal install derive to install Derive.

Supported Derivations

Data.Derive is not limited to any prebuild set of derivations, see later for how to add your own. Out of the box, we provide instances for the following libraries.

  • Arbitrary - from the library QuickCheck
  • ArbitraryOld - from the library QuickCheck-1.2.0.0
  • Arities - from the library derive
  • Binary - from the library binary
  • BinaryDefer - from the library binarydefer
  • Bounded - from the library base
  • Data - from the library base
  • DataAbstract - from the library base
  • Default - from the library derive
  • Enum - from the library base
  • EnumCyclic - from the library base
  • Eq - from the library base
  • Fold
  • Foldable - from the library base
  • From
  • Functor - from the library base
  • Has
  • Is
  • JSON - from the library json
  • LazySet
  • Lens - from the library data-lens
  • Monoid - from the library base
  • NFData - from the library deepseq
  • Ord - from the library base
  • Read - from the library base
  • Ref
  • Serial - from the library smallcheck
  • Serialize - from the library cereal
  • Set
  • Show - from the library base
  • Traversable - from the library base
  • Typeable - from the library base
  • UniplateDirect - from the library uniplate
  • UniplateTypeable - from the library uniplate
  • Update

    • Using the Derive program

    Let's imagine we've defined a data type: 

    data Color = RGB Int Int Int
           | CMYK Int Int Int Int
           deriving (Eq, Show)

    Now we wish to extend this to derive Binary and change to defining Eq using our library. To do this we simply add to the deriving clause. 

    data Color = RGB Int Int Int
           | CMYK Int Int Int Int
           deriving (Show {-! Eq, Binary !-})

    Or alternatively write: 

    {-!
deriving instance Eq Color
deriving instance Binary Color
!-}

    Now running derive on the program containing this code will generate appropriate instances. How do you combine these instances back into the code? There are various mechanisms supported.

    Appending to the module

    One way is to append the text to the bottom of the module, this can be done by passing the --append flag. If this is done, Derive will generate the required instances and place them at the bottom of the file, along with a checksum. Do not modify these instances.

    As a GHC preprocessor

    To use Derive as a GHC preprocessor, add the following line at the top of the source file: 

    {-# OPTIONS_GHC -F -pgmFderive -optF-F #-}

    This instructs GHC to apply a preprocessor (-F), and to use the preprocessor derive -F.

    Using CPP

    One way is to use CPP. Ensure your compiler is set up for compiling with the C Pre Processor. For example: 

    {-# LANGUAGE CPP #-}
{-# OPTIONS_DERIVE --output=file.h #-}

module ModuleName where

#include "file.h"

    Side-by-side Modules

    If you had Colour.Type, and wished to place the Binary instance in Colour.Binary, this can be done with: 

    {-# OPTIONS_DERIVE --output=Binary.hs --module=Colour.Binary --import #-}

    Here you ask for the output to go to a particular file, give a specific module name and import this module. This will only work if the data structure is exported non-abstractly.

    Using Template Haskell Derivations

    One of Derive's advantages over DrIFT is support for Template Haskell (abbreviated TH). Derive can be invoked automatically during the compilation process, and transparently supports deriving across module boundaries. The main disadvantage of TH-based deriving is that it is only portable to compilers that support TH; currently that is GHC only.

    To use the TH deriving system, with the same example as before: 

    {-# LANGUAGE TemplateHaskell #-}
import Data.DeriveTH
import Data.Binary

data Color = RGB Int Int Int
           | CMYK Int Int Int Int
           deriving (Show)

$( derive makeEq ''Color )
$( derive makeBinary ''Color )

    We need to tell the compiler to insert the instance using the TH splice construct, $( ... ) (the spaces are optional). The splice causes the compiler to run the function derive (exported from Data.DeriveTH), passing arguments makeFooBar and ''Color. The second argument deserves more explanation; it is a quoted symbol, somewhat like a quoted symbol in Lisp and with deliberately similar syntax. (Two apostrophes are used to specify that this name is to be resolved as a type constructor; just 'Color would look for a data constructor named Color.)

    Writing a New Derivation

    There are two methods for writing a new derivation, guessing or coding. The guessing method is substantially easier if it will work for you, but is limited to derivations with the following properties:

    If however your instance does meet these properties, you can use derivation by guess. Many instances do meet these conditions, for examples see: Eq, Ord, Data, Serial etc. If however you need to code the derivation manually see examples such as Update and Functor.

    derive-2.5.13/derive.cabal0000644000000000000000000000631512212421520013504 0ustar0000000000000000cabal-version: >= 1.6 build-type: Default name: derive version: 2.5.13 build-type: Simple copyright: Neil Mitchell 2006-2013 author: Neil Mitchell maintainer: Neil Mitchell homepage: http://community.haskell.org/~ndm/derive/ license: BSD3 license-file: LICENSE synopsis: A program and library to derive instances for data types category: Development description: Data.Derive is a library and a tool for deriving instances for Haskell programs. It is designed to work with custom derivations, SYB and Template Haskell mechanisms. The tool requires GHC, but the generated code is portable to all compilers. We see this tool as a competitor to DrIFT. extra-source-files: derive.htm source-repository head type: darcs location: http://community.haskell.org/~ndm/darcs/derive/ executable derive Main-Is: Main.hs library build-depends: base == 4.*, filepath, syb, template-haskell, containers, pretty, directory, process, bytestring, haskell-src-exts >= 1.14 && < 1.15, transformers >= 0.2 && < 0.4, uniplate >= 1.5 && < 1.7 exposed-modules: Data.DeriveMain Data.DeriveTH Data.DeriveDSL Data.Derive.All Data.Derive.DSL.Apply Data.Derive.DSL.Derive Data.Derive.DSL.DSL Data.Derive.DSL.HSE Data.Derive.DSL.SYB Data.Derive.Instance.Arities Data.Derive.Class.Arities Data.Derive.Class.Default Language.Haskell Language.Haskell.Convert Language.Haskell.TH.All Language.Haskell.TH.Compat Language.Haskell.TH.Data Language.Haskell.TH.ExpandSynonym Language.Haskell.TH.FixedPpr Language.Haskell.TH.Helper Language.Haskell.TH.Peephole -- GENERATED START Data.Derive.Arbitrary Data.Derive.ArbitraryOld Data.Derive.Arities Data.Derive.Binary Data.Derive.BinaryDefer Data.Derive.Bounded Data.Derive.Data Data.Derive.DataAbstract Data.Derive.Default Data.Derive.Enum Data.Derive.EnumCyclic Data.Derive.Eq Data.Derive.Fold Data.Derive.Foldable Data.Derive.From Data.Derive.Functor Data.Derive.Has Data.Derive.Is Data.Derive.JSON Data.Derive.LazySet Data.Derive.Lens Data.Derive.Monoid Data.Derive.NFData Data.Derive.Ord Data.Derive.Read Data.Derive.Ref Data.Derive.Serial Data.Derive.Serialize Data.Derive.Set Data.Derive.Show Data.Derive.Traversable Data.Derive.Typeable Data.Derive.UniplateDirect Data.Derive.UniplateTypeable Data.Derive.Update -- GENERATED STOP -- Mainly internal but some still people use them -- to implement derivations outside Data.Derive.Internal.Derivation other-modules: Data.Derive.Internal.Instance Data.Derive.Internal.Traversal Derive.Main Derive.Derivation Derive.Flags Derive.Generate Derive.Test Derive.Utils derive-2.5.13/Language/0000755000000000000000000000000012212421520012760 5ustar0000000000000000derive-2.5.13/Language/Haskell.hs0000644000000000000000000002356712212421520014714 0ustar0000000000000000 module Language.Haskell(module Language.Haskell, module Language.Haskell.Exts) where import Language.Haskell.Exts hiding (var,app,binds,paren) import Data.List import Data.Generics.Uniplate.Data import Data.Data import Data.Char infix 1 ? True ? b = const b False ? b = id -- insert explicit foralls foralls :: Type -> Type foralls x = TyForall (Just $ map UnkindedVar $ nub [y | TyVar y <- universe x]) [] x tyApps x [] = x tyApps x (y:ys) = tyApps (TyApp x y) ys fromTyApps (TyTuple _ xs) = (tyCon $ "(" ++ replicate (length xs - 1) ',' ++ ")", xs) fromTyApps (TyApp x y) = let (a,b) = fromTyApps x in (a, b ++ [y]) fromTyApps (TyList x) = (TyCon $ Special ListCon, [x]) fromTyApps x = (x, []) fromTyTuple (TyTuple _ xs) = xs fromTyTuple x = [x] fromTyParen (TyParen x) = fromTyParen x fromTyParen x = x fromTyParens = transform fromTyParen tyRoot = prettyPrint . fst . fromTyApps . fromTyParen isTyFun TyFun{} = True isTyFun _ = False isTyParen TyParen{} = True ; isTyParen _ = False fromTyList (TyList x) = Just x fromTyList (TyApp (TyCon (Special ListCon)) x) = Just x fromTyList x = Nothing x ~= y = prettyPrint x == y appP x@App{} y = App x y appP x y = App (paren x) (paren y) simplify :: Data a => a -> a simplify = transformBi fDecl . transformBi fMatch . transformBi fPat . transformBi fTyp . transformBi fExp where fExp (App op (List xs)) | op ~= "length" = Lit $ Int $ fromIntegral $ length xs | op ~= "head" = head xs | op ~= "null" = con $ show $ null xs fExp (InfixApp (Lit (Int i)) op (Lit (Int j))) | op ~= "-" = Lit $ Int $ i - j | op ~= "+" = Lit $ Int $ i + j | op ~= ">" = Con $ UnQual $ Ident $ show $ i > j fExp (InfixApp x op y) | op ~= "`const`" = x | op ~= "&&" && y ~= "True" = x | x ~= "id" && op ~= "." = y | y ~= "id" && op ~= "." = x fExp (InfixApp (Lit (String x)) op (Lit (String y))) | op ~= "++" = Lit $ String $ x ++ y fExp (App (App (App flp f) x) y) | flp ~= "flip" = fExp $ appP (fExp $ appP f y) x fExp (App (Paren x@App{}) y) = fExp $ App x y fExp (App (Paren (InfixApp x op y)) z) | op ~= "." = fExp $ appP x $ fExp $ appP y z fExp (App op x) | op ~= "id" = x fExp (App (App flp con) x) | flp ~= "flip" && con ~= "const" = var "id" fExp (App (App con x) y) | con ~= "const" = x fExp (App choose (Tuple _ [x@(ExpTypeSig _ y _),z])) | choose ~= "choose" && y == z = fExp $ App (var "return") x fExp (App op x) | op ~= "id" = x fExp (InfixApp (App when true) dot res) | when ~= "when" && true ~= "True" = res fExp (InfixApp x y z) | y ~= "++" && z ~= "[]" = x fExp (App (LeftSection x op) y) = fExp $ InfixApp x op (paren y) fExp (Paren x) | isAtom x = x fExp (Do [Qualifier x]) = x fExp (Do (Qualifier (App ret unit):xs)) | ret ~= "return" && unit ~= "()" = fExp $ Do xs fExp (Do (Generator _ (PVar x) (App ret y):xs)) | ret ~= "return" && once x2 xs = simplify $ Do $ subst x2 y xs where x2 = Var $ UnQual x fExp (Case (ExpTypeSig _ x@Lit{} _) alts) = fExp $ Case x alts fExp (Case (Lit x) alts) | good /= [] = head good where good = [z | Alt _ (PLit y) (UnGuardedAlt z) (BDecls []) <- alts, y == x] fExp (If x t f) | x ~= "True" = t | x ~= "False" = f fExp (App (App when b) x) | when ~= "when" && b ~= "True" = x | when ~= "when" && b ~= "False" = App (Var $ UnQual $ Ident "return") (Con $ Special $ TupleCon Boxed 0) fExp (App (Paren (Lambda _ [PVar x] y)) z) | once x2 y = fExp $ subst x2 z y where x2 = Var $ UnQual x fExp (App (Paren (Lambda _ [PWildCard] x)) _) = x fExp (Lambda s ps x) = Lambda s (minPat x ps) x fExp (Con x) = Con $ rename x fExp x = x fTyp (TyApp x y) | x ~= "[]" = TyList y fTyp (TyApp (TyCon (Special ListCon)) x) = TyList x fTyp (TyParen x@TyCon{}) = x fTyp (TyParen x@TyVar{}) = x fTyp (TyParen x@TyList{}) = x fTyp (TyCon nam) = TyCon $ rename nam fTyp x = x fPat (PParen x@(PApp _ [])) = x fPat (PParen (PParen x)) = PParen x fPat (PApp nam xs) = case rename nam of Special (TupleCon Boxed _) -> PTuple Boxed xs nam -> PApp nam xs fPat (PParen (PTuple l xs)) = PTuple l xs fPat x = x fMatch (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls) | x ~= "True" = fMatch $ Match sl nam pat sig (UnGuardedRhs bod) decls fMatch (Match sl nam [PVar x] sig (UnGuardedRhs (Case (Var (UnQual x2)) [Alt _ pat (UnGuardedAlt y) (BDecls [])])) decls) | x == x2 = fMatch $ Match sl nam [PParen pat] sig (UnGuardedRhs y) decls fMatch o@(Match a b c d e bind) = fBinds (Match a b (minPat o c) d e) bind fDecl (PatBind a b c d bind) = fBinds (PatBind a b c d) bind fDecl (FunBind xs) = FunBind $ filter (not . isGuardFalse) xs fDecl x = x fBinds context (BDecls bind) | inline /= [] = simplify $ subst (Var $ UnQual from) to $ context $ BDecls $ take i bind ++ drop (i+1) bind where f (PatBind _ (PVar x) Nothing (UnGuardedRhs bod) (BDecls [])) = [(x,bod)] f (FunBind [Match _ x [PVar v] Nothing (UnGuardedRhs (Paren (App bod (Var v2)))) (BDecls [])]) | UnQual v == v2 = [(x,bod)] f (FunBind [Match sl x pat Nothing (UnGuardedRhs bod) (BDecls [])]) = [(x,Paren $ Lambda sl pat bod)] f _ = [] (i,from,to) = head inline inline = [(i, x, bod) | (i,b) <- zip [0..] bind, (x,bod) <- f b , isAtom bod || once (Var $ UnQual x) (context $ BDecls bind)] fBinds a y = a y subst from to = transformBi $ \x -> if x == from then to else x once x y = length (filter (== x) (universeBi y)) <= 1 minPat o ps = transformBi f ps where known = nub [x | UnQual x <- universeBi o] f (PVar x) | x `notElem` known = PWildCard f (PAsPat x y) | x `notElem` known = y f x = x isGuardFalse (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls) = x ~= "False" isGuardFalse _ = False rename (UnQual (Ident ('(':xs@(x:_)))) | x == ',' = Special $ TupleCon Boxed $ length xs | x /= ')' = UnQual $ Symbol $ init xs rename x = x isAtom Con{} = True isAtom Var{} = True isAtom Lit{} = True isAtom Paren{} = True isAtom _ = False paren x = if isAtom x then x else Paren x sl = SrcLoc "" 0 0 noSl mr = transformBi (const sl) mr title (x:xs) = toUpper x : xs qname = UnQual . name var = Var . qname con = Con . qname tyVar = TyVar . name tyVarBind = UnkindedVar . name tyCon = TyCon . qname pVar = PVar . name qvop = QVarOp . UnQual . Symbol dataDeclType :: DataDecl -> Type dataDeclType d = tyApp (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d) dataDeclFields :: DataDecl -> [String] dataDeclFields = sort . nub . filter (not . null) . map fst . concatMap ctorDeclFields . dataDeclCtors -- A declaration that is either a DataDecl of GDataDecl type DataDecl = Decl type CtorDecl = Either QualConDecl GadtDecl type FieldDecl = [(String, BangType)] type FullDataDecl = (ModuleName, DataDecl) moduleName (Module _ name _ _ _ _ _) = name moduleDecls (Module _ _ _ _ _ _ decls) = decls moduleImports (Module _ _ _ _ _ imps _) = imps modulePragmas (Module _ _ pragmas _ _ _ _) = pragmas showDecls x = unlines $ map prettyPrint x tyApp x [] = x tyApp x xs = TyApp (tyApp x $ init xs) (last xs) tyFun [x] = x tyFun (x:xs) = TyFun x (tyFun xs) apps x [] = x apps x (y:ys) = apps (App x y) ys bind :: String -> [Pat] -> Exp -> Decl bind s p e = binds s [(p,e)] binds :: String -> [([Pat], Exp)] -> Decl binds n [([],e)] = PatBind sl (pVar n) Nothing (UnGuardedRhs e) (BDecls []) binds n xs = FunBind [Match sl (name n) p Nothing (UnGuardedRhs e) (BDecls []) | (p,e) <- xs] fromBangType (BangedTy x) = x fromBangType (UnBangedTy x) = x fromBangType (UnpackedTy x) = x isDataDecl :: Decl -> Bool isDataDecl DataDecl{} = True isDataDecl GDataDecl{} = True isDataDecl _ = False dataDeclSrcLoc :: DataDecl -> SrcLoc dataDeclSrcLoc (DataDecl sl _ _ _ _ _ _) = sl dataDeclSrcLoc (GDataDecl sl _ _ _ _ _ _ _) = sl dataDeclContext :: DataDecl -> Context dataDeclContext (DataDecl _ _ ctx _ _ _ _) = ctx dataDeclContext _ = error "dataDeclContext: not a DataDecl" dataDeclName :: DataDecl -> String dataDeclName (DataDecl _ _ _ name _ _ _) = prettyPrint name dataDeclName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name dataDeclVars :: DataDecl -> [String] dataDeclVars (DataDecl _ _ _ _ vars _ _) = map prettyPrint vars dataDeclArity :: DataDecl -> Int dataDeclArity = length . dataDeclVars dataDeclCtors :: DataDecl -> [CtorDecl] dataDeclCtors (DataDecl _ _ _ _ _ ctors _) = map Left ctors ctorDeclName :: CtorDecl -> String ctorDeclName = prettyPrint . ctorDeclName' ctorDeclName' :: CtorDecl -> Name ctorDeclName' (Left (QualConDecl _ _ _ (ConDecl name _))) = name ctorDeclName' (Left (QualConDecl _ _ _ (InfixConDecl _ name _))) = name ctorDeclName' (Left (QualConDecl _ _ _ (RecDecl name _))) = name ctorDeclFields :: CtorDecl -> FieldDecl ctorDeclFields (Left (QualConDecl _ _ _ (ConDecl name fields))) = map ((,) "") fields ctorDeclFields (Left (QualConDecl _ _ _ (InfixConDecl x1 name x2))) = map ((,) "") [x1,x2] ctorDeclFields (Left (QualConDecl _ _ _ (RecDecl name fields))) = [(prettyPrint a, b) | (as,b) <- fields, a <- as] ctorDeclArity :: CtorDecl -> Int ctorDeclArity = length . ctorDeclFields declName :: Decl -> String declName (DataDecl _ _ _ name _ _ _) = prettyPrint name declName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name declName (TypeDecl _ name _ _) = prettyPrint name derive-2.5.13/Language/Haskell/0000755000000000000000000000000012212421520014343 5ustar0000000000000000derive-2.5.13/Language/Haskell/Convert.hs0000644000000000000000000002220712212421520016322 0ustar0000000000000000{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} module Language.Haskell.Convert(Convert, convert) where import Language.Haskell as HS import Language.Haskell.TH.Syntax as TH import Control.Exception import Data.Typeable import System.IO.Unsafe import Data.Maybe class (Typeable a, Typeable b, Show a, Show b) => Convert a b where conv :: a -> b convert :: forall a b . Convert a b => a -> b convert a = unsafePerformIO $ (return $! (conv a :: b)) `Control.Exception.catch` (\(e :: SomeException) -> error $ msg e) where msg e = "Could not convert " ++ show (typeOf a) ++ " to " ++ show (typeOf (undefined :: b)) ++ "\n" ++ show a ++ "\n" ++ show e appT = foldl AppT c mr = convert mr instance Convert a b => Convert [a] [b] where conv = map c instance Convert TH.Dec HS.Decl where conv x = case x of DataD cxt n vs con ds -> f DataType cxt n vs con ds NewtypeD cxt n vs con ds -> f NewType cxt n vs [con] ds where f t cxt n vs con ds = DataDecl sl t (c cxt) (c n) (c vs) (c con) [] instance Convert TH.Name HS.TyVarBind where conv = UnkindedVar . c instance Convert TH.Name HS.Name where conv x = name $ if '.' `elem` x2 then reverse $ takeWhile (/= '.') $ reverse x2 else x2 where x2 = show x instance Convert TH.Name HS.QName where conv x = if x2 == Ident "[]" then Special ListCon else UnQual x2 where x2 = c x instance Convert TH.Con HS.QualConDecl where conv (ForallC vs cxt x) = QualConDecl sl (c vs) (c cxt) (c x) conv x = QualConDecl sl [] [] (c x) instance Convert TH.Con HS.ConDecl where conv (NormalC n xs) = ConDecl (c n) (c xs) conv (RecC n xs) = RecDecl (c n) [([c x], c (y,z)) | (x,y,z) <- xs] conv (InfixC x n y) = InfixConDecl (c x) (c n) (c y) instance Convert TH.StrictType HS.BangType where conv (IsStrict, x) = BangedTy $ c x conv (NotStrict, x) = UnBangedTy $ c x #if __GLASGOW_HASKELL__ >= 704 conv (Unpacked, x) = BangedTy $ c x #endif instance Convert TH.Type HS.Type where conv (ForallT xs cxt t) = TyForall (Just $ c xs) (c cxt) (c t) conv (VarT x) = TyVar $ c x conv (ConT x) | ',' `elem` show x = TyTuple Boxed [] | otherwise = TyCon $ c x conv (AppT (AppT ArrowT x) y) = TyFun (c x) (c y) conv (AppT ListT x) = TyList $ c x conv (TupleT _) = TyTuple Boxed [] conv (AppT x y) = case c x of TyTuple b xs -> TyTuple b $ xs ++ [c y] x -> TyApp x $ c y instance Convert TH.Type HS.Asst where conv (ConT x) = ClassA (UnQual $ c x) [] conv (AppT x y) = case c x of ClassA a b -> ClassA a (b ++ [c y]) instance Convert HS.Decl TH.Dec where conv (InstDecl _ cxt nam typ ds) = InstanceD (c cxt) (c $ tyApp (TyCon nam) typ) [c d | InsDecl d <- ds] conv (FunBind ms@(HS.Match _ nam _ _ _ _:_)) = FunD (c nam) (c ms) conv (PatBind _ p _ bod ds) = ValD (c p) (c bod) (c ds) conv (TypeSig _ [nam] typ) = SigD (c nam) (c $ foralls typ) conv (DataDecl _ DataType ctx nam typ cs ds) = DataD (c ctx) (c nam) (c typ) (c cs) (c (map fst ds)) conv (DataDecl _ NewType ctx nam typ [con] ds) = NewtypeD (c ctx) (c nam) (c typ) (c con) (c (map fst ds)) instance Convert HS.QualConDecl TH.Con where conv (QualConDecl _ [] [] con) = c con conv (QualConDecl _ vs cx con) = ForallC (c vs) (c cx) (c con) instance Convert HS.ConDecl TH.Con where conv (ConDecl nam typ) = NormalC (c nam) (c typ) conv (InfixConDecl l nam r) = InfixC (c l) (c nam) (c r) conv (RecDecl nam fs) = RecC (c nam) (concatMap c fs) instance Convert HS.BangType TH.StrictType where conv (BangedTy t) = (IsStrict,c t) conv (UnBangedTy t) = (NotStrict,c t) instance Convert ([HS.Name],HS.BangType) [TH.VarStrictType] where conv (names,bt) = [(c name,s,t) | name <- names] where (s,t) = c bt instance Convert HS.Asst TH.Type where conv (InfixA x y z) = c $ ClassA y [x,z] conv (ClassA x y) = appT (ConT $ c x) (c y) instance Convert HS.Type TH.Type where conv (TyCon (Special ListCon)) = ListT conv (TyCon (Special UnitCon)) = TupleT 0 conv (TyParen x) = c x conv (TyForall x y z) = ForallT (c $ fromMaybe [] x) (c y) (c z) conv (TyVar x) = VarT $ c x conv (TyCon x) = if x ~= "[]" then error "here" else ConT $ c x conv (TyFun x y) = AppT (AppT ArrowT (c x)) (c y) conv (TyList x) = AppT ListT (c x) conv (TyTuple _ x) = appT (TupleT (length x)) (c x) conv (TyApp x y) = AppT (c x) (c y) instance Convert HS.Name TH.Name where conv = mkName . filter (`notElem` "()") . prettyPrint instance Convert HS.Match TH.Clause where conv (HS.Match _ _ ps _ bod ds) = Clause (c ps) (c bod) (c ds) instance Convert HS.Rhs TH.Body where conv (UnGuardedRhs x) = NormalB (c x) conv (GuardedRhss x) = GuardedB (c x) instance Convert HS.Exp TH.Exp where conv (Con (Special UnitCon)) = TupE [] conv (Var x) = VarE (c x) conv (Con x) = ConE (c x) conv (Lit x) = LitE (c x) conv (App x y) = AppE (c x) (c y) conv (Paren x) = c x conv (InfixApp x y z) = InfixE (Just $ c x) (c y) (Just $ c z) conv (LeftSection x y) = InfixE (Just $ c x) (c y) Nothing conv (RightSection y z) = InfixE Nothing (c y) (Just $ c z) conv (Lambda _ x y) = LamE (c x) (c y) conv (Tuple _ x) = TupE (c x) conv (If x y z) = CondE (c x) (c y) (c z) conv (Let x y) = LetE (c x) (c y) conv (Case x y) = CaseE (c x) (c y) conv (Do x) = DoE (c x) conv (EnumFrom x) = ArithSeqE $ FromR (c x) conv (EnumFromTo x y) = ArithSeqE $ FromToR (c x) (c y) conv (EnumFromThen x y) = ArithSeqE $ FromThenR (c x) (c y) conv (EnumFromThenTo x y z) = ArithSeqE $ FromThenToR (c x) (c y) (c z) conv (List x) = ListE (c x) conv (ExpTypeSig _ x y) = SigE (c x) (c y) conv (RecConstr x y) = RecConE (c x) (c y) conv (RecUpdate x y) = RecUpdE (c x) (c y) -- Work around bug 3395, convert to do notation instead conv (ListComp x y) = CompE $ c $ y ++ [QualStmt $ Qualifier x] instance Convert HS.GuardedRhs (TH.Guard, TH.Exp) where conv = undefined instance Convert HS.Binds [TH.Dec] where conv (BDecls x) = c x instance Convert HS.Pat TH.Pat where conv (PParen x) = c x conv (PLit x) = LitP (c x) conv (PTuple _ x) = TupP (c x) conv (PApp x y) = ConP (c x) (c y) conv (PVar x) = VarP (c x) conv (PInfixApp x y z) = InfixP (c x) (c y) (c z) conv (PIrrPat x) = TildeP (c x) conv (PAsPat x y) = AsP (c x) (c y) conv (PWildCard) = WildP conv (PRec x y) = RecP (c x) (c y) conv (PList x) = ListP (c x) conv (PatTypeSig _ x y) = SigP (c x) (c y) instance Convert HS.Literal TH.Lit where conv (Char x) = CharL x conv (String x) = StringL x conv (Int x) = IntegerL x conv (Frac x) = RationalL x conv (PrimInt x) = IntPrimL x conv (PrimWord x) = WordPrimL x conv (PrimFloat x) = FloatPrimL x conv (PrimDouble x) = DoublePrimL x instance Convert HS.QName TH.Name where conv (UnQual x) = c x conv (Qual m x) = c (Ident $ prettyPrint m ++ "." ++ prettyPrint x) conv (Special (TupleCon Boxed i)) = Name (mkOccName $ "(" ++ replicate (i-1) ',' ++ ")") NameS instance Convert HS.PatField TH.FieldPat where conv = undefined instance Convert HS.QOp TH.Exp where conv (QVarOp x) = c $ Var x conv (QConOp x) = c $ Con x instance Convert HS.Alt TH.Match where conv (Alt _ x y z) = TH.Match (c x) (c y) (c z) instance Convert HS.Stmt TH.Stmt where conv (Generator _ x y) = BindS (c x) (c y) conv (LetStmt x) = LetS (c x) conv (Qualifier x) = NoBindS (c x) instance Convert HS.QualStmt TH.Stmt where conv (QualStmt x) = c x instance Convert HS.FieldUpdate TH.FieldExp where conv (FieldUpdate x y) = (c x, c y) instance Convert HS.TyVarBind TH.Name where conv (UnkindedVar x) = c x instance Convert HS.GuardedAlts TH.Body where conv (UnGuardedAlt x) = NormalB (c x) conv (GuardedAlts x) = GuardedB (c x) instance Convert HS.GuardedAlt (TH.Guard, TH.Exp) where conv (GuardedAlt _ x y) = (PatG (c x), c y) #if __GLASGOW_HASKELL__ >= 612 instance Convert TH.TyVarBndr HS.TyVarBind where conv (PlainTV x) = UnkindedVar $ c x conv (KindedTV x y) = KindedVar (c x) $ c y #if __GLASGOW_HASKELL__ < 706 instance Convert TH.Kind HS.Kind where conv StarK = KindStar conv (ArrowK x y) = KindFn (c x) $ c y #else instance Convert TH.Kind HS.Kind where conv StarT = KindStar conv (AppT (AppT ArrowT x) y) = KindFn (c x) (c y) #endif instance Convert TH.Pred HS.Asst where conv (ClassP x y) = ClassA (UnQual $ c x) $ c y conv (TH.EqualP x y) = HS.EqualP (c x) $ c y instance Convert HS.Asst TH.Pred where conv (ClassA x y) = ClassP (c x) $ c y conv (HS.EqualP x y) = TH.EqualP (c x) $ c y instance Convert HS.TyVarBind TH.TyVarBndr where conv (UnkindedVar x) = PlainTV $ c x conv (KindedVar x y) = KindedTV (c x) $ c y #if __GLASGOW_HASKELL__ < 706 instance Convert HS.Kind TH.Kind where conv KindStar = StarK conv (KindFn x y) = ArrowK (c x) $ c y #else instance Convert HS.Kind TH.Kind where conv KindStar = StarT conv (KindFn x y) = AppT (AppT ArrowT (c x)) (c y) #endif #endif derive-2.5.13/Language/Haskell/TH/0000755000000000000000000000000012212421520014656 5ustar0000000000000000derive-2.5.13/Language/Haskell/TH/Peephole.hs0000644000000000000000000001306712212421520016762 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} module Language.Haskell.TH.Peephole(peephole, replaceVar, replaceVars) where import Language.Haskell.TH.Syntax import Language.Haskell.TH.Helper import Data.Generics import Data.Maybe import Data.List import Debug.Trace traceMode = False peephole :: Data a => a -> a peephole = everywhere (mkT peep) . everywhere (mkT peepPat) -- find a given string, and replace it with a particular expression -- must succeed, so crashes readily (deliberately!) replaceVars :: [(Name,Exp)] -> Exp -> Exp replaceVars rep orig = fExp orig where fExp x = case x of VarE y -> fromMaybe x $ lookup y rep ConE _ -> x LitE _ -> x AppE x y -> AppE (fExp x) (fExp y) CaseE x y -> CaseE (fExp x) (map fMatch y) TupE xs -> TupE (map fExp xs) ListE xs -> ListE (map fExp xs) LamE x y -> LamE x (fPat x y) _ | null $ map fst rep `intersect` getNames x -> x _ -> error $ "replaceVar: " ++ show x getNames x = everything (++) ([] `mkQ` f) x where f :: Name -> [Name] f x = [x] fMatch o@(Match pat (NormalB bod) []) = Match pat (NormalB $ fPat [pat] bod) [] -- given these pattern have come into scope -- continue matching on the rest fPat :: [Pat] -> Exp -> Exp fPat pat = replaceVars (filter ((`notElem` used) . fst) rep) where used = concatMap usedPats pat usedPats x = everything (++) ([] `mkQ` f) x where f (VarP x) = [x] f _ = [] replaceVar :: Name -> Exp -> Exp -> Exp replaceVar name with = replaceVars [(name,with)] -- based on the rewrite combinator in Play peep :: Exp -> Exp peep (ListE xs) | not (null xs) && all (isJust . fromLitChar) xs = peep $ LitE $ StringL $ map (fromJust . fromLitChar) xs where fromLitChar (LitE (CharL x)) = Just x fromLitChar _ = Nothing peep (AppE x y) | x ~= "id" = y peep (AppE (AppE op x) y) | Just res <- peepBin op x y = res peep (InfixE (Just x) op (Just y)) | Just res <- peepBin op x y = res peep (LamE [] x) = x peep (LamE [VarP x] (VarE y)) | x == y = l0 "id" peep (DoE [NoBindS x]) = x peep x@(ConE _) | x ~= "[]" = ListE [] peep (AppE (AppE cons x) nil) | cons ~= ":" && nil ~= "[]" = ListE [x] peep (DoE [BindS (VarP p) (AppE ret (LitE val)),NoBindS e]) | ret ~= "return" = peep $ replaceVar p (LitE val) e peep (LamE [TupP [VarP x, VarP y]] (VarE z)) | x == z = l0 "fst" | y == z = l0 "snd" peep (AppE (LamE (VarP x:xs) y) z) | simple z = peep $ LamE xs (replaceVar x z y) peep (AppE (AppE bind (AppE ret x)) y) | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x peep (InfixE (Just (AppE ret x)) bind (Just y)) | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x peep (InfixE (Just (AppE pure x)) ap y) | ap ~= "<*>" && pure ~= "pure" = peep $ InfixE (Just x) (l0 "<$>") y peep (InfixE (Just x) fmap (Just (AppE pure y))) | fmap ~= "<$>" && pure ~= "pure" = peep $ AppE pure (peep $ AppE x y) peep (AppE append (ListE [x])) | append ~= "++" = peep $ AppE (l0 ":") x peep (InfixE (Just (ListE [x])) append y) | append ~= "++" = peep $ InfixE (Just x) (l0 ":") y peep (InfixE (Just x) cons (Just (ListE xs))) | cons ~= ":" = peep $ ListE (x:xs) peep (AppE (AppE (AppE comp f) g) x) | comp ~= "." = peep $ AppE f (peep $ AppE g x) peep (AppE (InfixE (Just f) comp (Just g)) x) | comp ~= "." = peep $ AppE f (peep $ AppE g x) peep (AppE (AppE (AppE flip f) x) y) | flip ~= "flip" = peep $ AppE (AppE f y) x peep (AppE (InfixE (Just x) op Nothing) y) = peep $ InfixE (Just x) op (Just y) peep (AppE (InfixE Nothing op (Just y)) x) = peep $ InfixE (Just x) op (Just y) peep (AppE f (LamE x (ListE [y]))) | f ~= "concatMap" = peep $ AppE (l0 "map") (peep $ LamE x y) peep (AppE f (ListE xs)) | f ~= "head" && not (null xs) = head xs | f ~= "reverse" = ListE $ reverse xs peep (AppE f (TupE [x,y])) | f ~= "choose" && x == y = peep $ AppE (VarE (mkName "return")) x peep (AppE (AppE sq o@(AppE rnf x)) (TupE [])) | sq ~= "seq" && rnf ~= "rnf" = o peep (CaseE (LitE x) (Match (LitP y) (NormalB z) [] : _)) | x == y = z peep (AppE len (ListE xs)) | len ~= "length" = LitE $ IntegerL $ toInteger $ length xs peep (TupE [x]) = x peep (AppE (LamE [pat] x) e) = CaseE e [Match pat (NormalB x) []] peep (AppE (CaseE e [Match p (NormalB x) []]) y) = CaseE e [Match p (NormalB $ peep $ AppE x y) []] -- allow easy flip to tracing mode peep x | traceMode = trace (show x) x peep x = x peepPat :: Pat -> Pat peepPat (ListP xs) | all (\x -> case x of LitP (CharL _) -> True _ -> False) xs = LitP $ StringL $ map (\(LitP (CharL x)) -> x) xs peepPat x = x peepBin :: Exp -> Exp -> Exp -> Maybe Exp peepBin op x y | op ~= "." && x ~= "id" = Just y | op ~= "." && y ~= "id" = Just x | op ~= "&&" && y ~= "True" = Just x | op ~= "const" = Just x | op ~= "map" && x ~= "id" = Just y | op ~= "++" && x ~= "[]" = Just y | op ~= "++" && y ~= "[]" = Just x | op ~= "." && y ~= "id" = Just x | op ~= ">>" && x ~= "return" && y == TupE [] = Just $ l0 "id" | op ~= "$" = Just $ peep $ AppE x y peepBin op (LitE (StringL x)) (LitE (StringL y)) | op ~= "++" = Just $ LitE $ StringL (x++y) peepBin _ _ _ = Nothing (VarE f) ~= x = show f == x (ConE f) ~= x = show f == x (ListE []) ~= "[]" = True _ ~= _ = False simple (VarE _) = True simple (LitE _) = True simple _ = False derive-2.5.13/Language/Haskell/TH/Helper.hs0000644000000000000000000001625612212421520016443 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -- | These small short-named functions are intended to make the -- construction of abstranct syntax trees less tedious. module Language.Haskell.TH.Helper where import Data.Char import Language.Haskell.TH.Syntax import Language.Haskell.TH.Data import Language.Haskell.TH.Compat -- * Special folds for the guessing applyWith, foldl1With, foldr1With :: Exp -> [Exp] -> Exp applyWith join xs = foldl AppE join xs foldl1With join xs = foldr1 (\y x -> AppE (AppE join y) x) xs foldr1With join xs = foldr1 (\y x -> AppE (AppE join x) y) xs -- * Syntax elements -- -- | A simple clause, without where or guards. sclause :: [Pat] -> Exp -> Clause sclause pats body = Clause pats (NormalB body) [] -- | A default clause with N arguments. defclause :: Int -> Exp -> Clause defclause num = sclause (replicate num WildP) -- | A simple Val clause sval :: Pat -> Exp -> Dec sval pat body = ValD pat (NormalB body) [] case' :: Exp -> [(Pat, Exp)] -> Exp case' exp alts = CaseE exp [ Match x (NormalB y) [] | (x,y) <- alts ] (->:) :: String -> Exp -> Exp (->:) nm bdy = LamE [vr nm] bdy -- | We provide 3 standard instance constructors -- instance_default requires C for each free type variable -- instance_none requires no context -- instance_context requires a given context instance_none :: String -> DataDef -> [Dec] -> Dec instance_none = instance_context [] instance_default :: String -> DataDef -> [Dec] -> Dec instance_default n = instance_context [n] n instance_context :: [String] -> String -> DataDef -> [Dec] -> Dec instance_context req cls dat defs = InstanceD ctx hed defs where vrs = vars 't' (dataArity dat) hed = l1 cls (lK (dataName dat) vrs) ctx = [typeToPred $ l1 r v | r <- req, v <- vrs] -- | Build an instance of a class for a data type, using the heuristic -- that the type is itself required on all type arguments. simple_instance :: String -> DataDef -> [Dec] -> [Dec] simple_instance cls dat defs = [instance_default cls dat defs] -- | Build an instance of a class for a data type, using the class at the given types generic_instance :: String -> DataDef -> [Type] -> [Dec] -> [Dec] generic_instance cls dat ctxTypes defs = [InstanceD ctx hed defs] where vrs = vars 't' (dataArity dat) hed = l1 cls (lK (dataName dat) vrs) ctx = map (typeToPred . l1 cls) ctxTypes -- | Build a type signature declaration with a string name sigN :: String -> Type -> Dec sigN nam ty = SigD (mkName nam) ty -- | Build a fundecl with a string name funN :: String -> [Clause] -> Dec funN nam claus = FunD (mkName nam) claus -- * Pattern vs Value abstraction class Eq nm => NameLike nm where toName :: nm -> Name instance NameLike Name where toName = id instance NameLike String where toName = mkName -- | The class used to overload lifting operations. To reduce code -- duplication, we overload the wrapped constructors (and everything -- else, but that's irrelevant) to work in patterns, expressions, and -- types. class Valcon a where -- | Build an application node, with a name for a head and a -- provided list of arguments. lK :: NameLike nm => nm -> [a] -> a -- | Reference a named variable. vr :: NameLike nm => nm -> a -- | Lift a TH 'Lit' raw_lit :: Lit -> a -- | Tupling tup :: [a] -> a -- | Listing lst :: [a] -> a instance Valcon Exp where lK nm ys = let name = toName nm in case (nameBase name, ys) of ("[]", []) -> ConE name ("[]", xs) -> lst xs ((x:_), args) | isUpper x || x == ':' -> foldl AppE (ConE name) args ((x:_), [a,b]) | isOper x -> InfixE (Just a) (VarE name) (Just b) where isOper x = not (isAlpha x || x == '_') (nm, args) -> foldl AppE (VarE name) args vr = VarE . toName raw_lit = LitE tup = TupE lst = ListE instance Valcon Pat where lK = ConP . toName vr = VarP . toName raw_lit = LitP tup = TupP lst = ListP instance Valcon Type where lK nm = foldl AppT (if bNm == "[]" then ListT else ConT (mkName bNm)) where bNm = nameBase (toName nm) vr = VarT . toName raw_lit = error "raw_lit @ Type" -- XXX work around bug in GHC < 6.10 -- (see http://hackage.haskell.org/trac/ghc/ticket/2358 for details) tup [t] = t tup ts = foldl AppT (TupleT (length ts)) ts lst = error "lst @ Type" -- | Build an application node without a given head app :: Exp -> [Exp] -> Exp app root args = foldl AppE root args -- | This class is used to overload literal construction based on the -- type of the literal. class LitC a where lit :: Valcon p => a -> p instance LitC Integer where lit = raw_lit . IntegerL instance LitC Char where lit = raw_lit . CharL instance LitC a => LitC [a] where lit = lst . map lit instance (LitC a, LitC b) => LitC (a,b) where lit (x,y) = tup [lit x, lit y] instance (LitC a, LitC b, LitC c) => LitC (a,b,c) where lit (x,y,z) = tup [lit x, lit y, lit z] instance LitC () where lit () = tup [] -- * Constructor abstraction dataVars :: DataDef -> [Type] dataVars dat = take (dataArity dat) $ map (VarT . mkName . return) ['a'..] -- | Common pattern: list of a familiy of variables vars :: Valcon a => Char -> Int -> [a] vars c n = map (vrn c) [1 .. n] -- | Variable based on a letter + number vrn :: Valcon a => Char -> Int -> a vrn c n = vr (c : show n) -- | Make a list of variables, one for each argument to a constructor ctv :: Valcon a => CtorDef -> Char -> [a] ctv ctor c = vars c (ctorArity ctor) -- | Make a simple pattern to bind a constructor ctp :: Valcon a => CtorDef -> Char -> a ctp ctor c = lK (ctorName ctor) (ctv ctor c) -- | Reference the constructor itself ctc :: Valcon a => CtorDef -> a ctc = l0 . ctorName -- * Lift a constructor over a fixed number of arguments. l0 :: (NameLike nm, Valcon a) => nm -> a l1 :: (NameLike nm, Valcon a) => nm -> a -> a l2 :: (NameLike nm, Valcon a) => nm -> a -> a -> a l0 s = lK s [] l1 s a = lK s [a] l2 s a b = lK s [a,b] -- * Pre-lifted versions of common operations true, false, nil :: Valcon a => a hNil', hZero' :: Type true = l0 "True" false = l0 "False" nil = l0 "[]" unit = lit () hNil' = l0 "HNil" hZero' = l0 "HZero" id' = l0 "id" cons :: Valcon a => a -> a -> a cons = l2 ":" box :: Valcon a => a -> a return', const' :: Exp -> Exp hSucc' :: Type -> Type box x = cons x nil return' = l1 "return" const' = l1 "const" hSucc' = l1 "HSucc" (==:), (&&:), (++:), (>>=:), (>>:), (.:), ap', (>:) :: Exp -> Exp -> Exp hCons' :: Type -> Type -> Type (==:) = l2 "==" (&&:) = l2 "&&" (++:) = l2 "++" (>>=:) = l2 ">>=" (>>:) = l2 ">>" (.:) = l2 "." (>:) = l2 ">" ap' = l2 "ap" hCons' = l2 "HCons" -- | Build a chain of expressions, with an appropriate terminal -- sequence__ does not require a unit at the end (all others are optimised automatically) (&&::), (++::), (>>::), sequence__, (.::) :: [Exp] -> Exp (&&::) = foldr (&&:) true (++::) = foldr (++:) nil (>>::) = foldr (>>:) (return' unit) (.::) = foldr (.:) id' sequence__ [] = return' unit sequence__ xs = foldr1 (>>:) xs -- | K-way liftM liftmk :: Exp -> [Exp] -> Exp liftmk hd args = foldl ap' (return' hd) args derive-2.5.13/Language/Haskell/TH/FixedPpr.hs0000644000000000000000000003545512212421520016747 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, CPP #-} -- TH.Ppr contains a prettyprinter for the -- Template Haskell datatypes module Language.Haskell.TH.FixedPpr where -- All of the exports from this module should -- be "public" functions. The main module TH -- re-exports them all. import Text.PrettyPrint.HughesPJ (render) import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax import Language.Haskell.TH.Data(isTupleT) import Data.Char ( toLower, isAlpha ) nestDepth :: Int nestDepth = 4 type Precedence = Int appPrec, opPrec, noPrec :: Precedence appPrec = 2 -- Argument of a function application opPrec = 1 -- Argument of an infix operator noPrec = 0 -- Others parensIf :: Bool -> Doc -> Doc parensIf True d = parens d parensIf False d = d ------------------------------ -- Show name with `` and () stripped, so that behaviour is the same -- with fixed and broken syntax-libs showNameRaw :: Name -> String showNameRaw = clean . show where clean ('(':xs) = init xs clean ('`':xs) = init xs clean xs = xs isPrefixName :: Name -> Bool isPrefixName = classify . showNameRaw where classify xs = case break (=='.') xs of (_,(_:xs')) -> classify xs' ((x:xs),[]) -> isAlpha x || x == '_' _ -> False -- operators ending with . pprName_ :: Bool -> Name -> Doc pprName_ True nm | isPrefixName nm = text (showNameRaw nm) | otherwise = text ("(" ++ showNameRaw nm ++ ")") pprName_ False nm | isPrefixName nm = text ("`" ++ showNameRaw nm ++ "`") | otherwise = text (showNameRaw nm) ------------------------------ pprint :: Ppr a => a -> String pprint x = render $ to_HPJ_Doc $ ppr x class Ppr a where ppr :: a -> Doc ppr_list :: [a] -> Doc ppr_list = vcat . map ppr instance Ppr a => Ppr [a] where ppr x = ppr_list x ------------------------------ instance Ppr Name where ppr v = pprName_ True v -- text (show v) ------------------------------ instance Ppr Info where #if __GLASGOW_HASKELL__ >= 700 ppr (ClassI d _) = ppr d #else ppr (ClassI d) = ppr d #endif ppr (TyConI d) = ppr d ppr (PrimTyConI name arity is_unlifted) = text "Primitive" <+> (if is_unlifted then text "unlifted" else empty) <+> text "type construtor" <+> quotes (ppr name) <+> parens (text "arity" <+> int arity) ppr (ClassOpI v ty cls fix) = text "Class op from" <+> ppr cls <> colon <+> vcat [ppr_sig v ty, pprFixity v fix] ppr (DataConI v ty tc fix) = text "Constructor from" <+> ppr tc <> colon <+> vcat [ppr_sig v ty, pprFixity v fix] ppr (TyVarI v ty) = text "Type variable" <+> ppr v <+> equals <+> ppr ty ppr (VarI v ty mb_d fix) = vcat [ppr_sig v ty, pprFixity v fix, case mb_d of { Nothing -> empty; Just d -> ppr d }] ppr_sig v ty = ppr v <+> text "::" <+> ppr ty pprFixity :: Name -> Fixity -> Doc pprFixity v f | f == defaultFixity = empty pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v where ppr_fix InfixR = text "infixr" ppr_fix InfixL = text "infixl" ppr_fix InfixN = text "infix" ------------------------------ instance Ppr Exp where ppr = pprExp noPrec pprExpInfix :: Exp -> Doc pprExpInfix (VarE v) = pprName_ False v pprExpInfix (ConE c) = pprName_ False c pprExp :: Precedence -> Exp -> Doc pprExp _ (VarE v) = ppr v pprExp _ (ConE c) | isTupleT (ConT c) = text (nameBase c) | c == '[] = text ("[]") | c == '(:) = text ("(:)") | otherwise = ppr c pprExp i (LitE l) = pprLit i l pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1 <+> pprExp appPrec e2 pprExp i (InfixE (Just e1) op (Just e2)) = parensIf (i >= opPrec) $ pprExp opPrec e1 <+> pprExpInfix op <+> pprExp opPrec e2 pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1 <+> pprExpInfix op <+> pprMaybeExp noPrec me2 pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps) <+> text "->" <+> ppr e pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es -- Nesting in Cond is to avoid potential problems in do statments pprExp i (CondE guard true false) = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard, nest 1 $ text "then" <+> ppr true, nest 1 $ text "else" <+> ppr false] pprExp i (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds $$ text " in" <+> ppr e pprExp i (CaseE e ms) = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of" $$ nest nestDepth (ppr ms) pprExp i (DoE ss) = parensIf (i > noPrec) $ text "do" <+> ppr ss pprExp _ (CompE []) = error "Can't happen: pprExp (CompExp [])" -- This will probably break with fixity declarations - would need a ';' pprExp _ (CompE ss) = text "[" <> ppr s <+> text "|" <+> (sep $ punctuate comma $ map ppr ss') <> text "]" where s = last ss ss' = init ss pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs) pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e) pprMaybeExp :: Precedence -> Maybe Exp -> Doc pprMaybeExp _ Nothing = empty pprMaybeExp i (Just e) = pprExp i e ------------------------------ instance Ppr Stmt where ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e ppr (LetS ds) = text "let" <+> ppr ds ppr (NoBindS e) = ppr e ppr (ParS sss) = sep $ punctuate (text "|") $ map (sep . punctuate comma . map ppr) sss ------------------------------ instance Ppr Match where ppr (Match p rhs ds) = ppr p <+> pprBody False rhs $$ where_clause ds ------------------------------ pprBody :: Bool -> Body -> Doc pprBody eq (GuardedB xs) = nest nestDepth $ vcat $ map do_guard xs where eqd = if eq then text "=" else text "->" do_guard (NormalG g, e) = text "|" <+> ppr g <+> eqd <+> ppr e do_guard (PatG ss, e) = text "|" <+> vcat (map ppr ss) $$ nest nestDepth (eqd <+> ppr e) pprBody eq (NormalB e) = (if eq then text "=" else text "->") <+> ppr e instance Ppr Body where ppr = pprBody True ------------------------------ pprLit :: Precedence -> Lit -> Doc pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0) (integer x <> char '#') pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0) (float (fromRational x) <> char '#') pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0) (double (fromRational x) <> text "##") pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x) pprLit _ (CharL c) = text (show c) pprLit _ (StringL s) = text (show s) pprLit i (RationalL rat) = parensIf (i > noPrec) $ rational rat instance Ppr Lit where ppr = pprLit 10 ------------------------------ instance Ppr Pat where ppr = pprPat noPrec pprPat :: Precedence -> Pat -> Doc pprPat i (LitP l) = pprLit i l pprPat _ (VarP v) = ppr v pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps pprPat i (ConP s ps) = parensIf (i > noPrec) $ x <+> sep (map (pprPat appPrec) ps) where x | isTupleT (ConT s) = text (nameBase s) | s == '[] = text "[]" | s == '(:) = text "(:)" | otherwise = ppr s pprPat i (InfixP p1 n p2) = parensIf (i > noPrec) $ pprPat opPrec p1 <+> pprName_ False n <+> pprPat opPrec p2 pprPat i (TildeP p) = parensIf (i > noPrec) $ text "~" <> pprPat appPrec p pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@" <> pprPat appPrec p pprPat _ WildP = text "_" pprPat _ (RecP nm fs) = parens $ ppr nm <+> braces (sep $ punctuate comma $ map (\(s,p) -> ppr s <+> equals <+> ppr p) fs) pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t ------------------------------ instance Ppr Dec where ppr (FunD f cs) = vcat $ map (\c -> ppr f <+> ppr c) cs ppr (ValD p r ds) = ppr p <+> pprBody True r $$ where_clause ds ppr (TySynD t xs rhs) = text "type" <+> ppr t <+> hsep (map ppr xs) <+> text "=" <+> ppr rhs ppr (DataD ctxt t xs cs decs) = text "data" <+> pprCxt ctxt <+> ppr t <+> hsep (map ppr xs) <+> sep (pref $ map ppr cs) $$ if null decs then empty else nest nestDepth $ text "deriving" <+> parens (hsep $ punctuate comma $ map ppr decs) where pref :: [Doc] -> [Doc] pref [] = [] -- Can't happen in H98 pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds ppr (NewtypeD ctxt t xs c decs) = text "newtype" <+> pprCxt ctxt <+> ppr t <+> hsep (map ppr xs) <+> char '=' <+> ppr c $$ if null decs then empty else nest nestDepth $ text "deriving" <+> parens (hsep $ punctuate comma $ map ppr decs) ppr (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds $$ where_clause ds ppr (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i $$ where_clause (map deQualLhsHead ds) ppr (SigD f t) = ppr f <+> text "::" <+> ppr t ppr (ForeignD f) = ppr f deQualLhsHead :: Dec -> Dec deQualLhsHead (FunD n cs) = FunD (deQualName n) cs deQualLhsHead (ValD p b ds) = ValD (go p) b ds where go (VarP n) = VarP (deQualName n) go (InfixP p1 n p2) = InfixP p1 (deQualName n) p2 go x = x deQualLhsHead x = x deQualName :: Name -> Name deQualName = mkName . nameBase ------------------------------ instance Ppr FunDep where ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys) ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs)) ------------------------------ instance Ppr Foreign where ppr (ImportF callconv safety impent as typ) = text "foreign import" <+> showtextl callconv <+> showtextl safety <+> text (show impent) <+> ppr as <+> text "::" <+> ppr typ ppr (ExportF callconv expent as typ) = text "foreign export" <+> showtextl callconv <+> text (show expent) <+> ppr as <+> text "::" <+> ppr typ ------------------------------ instance Ppr Clause where ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs $$ where_clause ds ------------------------------ instance Ppr Con where ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts) ppr (RecC c vsts) = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts)) ppr (InfixC st1 c st2) = pprStrictType st1 <+> pprName_ False c <+> pprStrictType st2 ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns) <+> char '.' <+> pprCxt ctxt <+> ppr con ------------------------------ pprVarStrictType :: (Name, Strict, Type) -> Doc -- Slight infelicity: with print non-atomic type with parens pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t) ------------------------------ pprStrictType :: (Strict, Type) -> Doc -- Prints with parens if not already atomic pprStrictType (IsStrict, t) = char '!' <> pprParendType t pprStrictType (NotStrict, t) = pprParendType t ------------------------------ pprParendType :: Type -> Doc pprParendType (VarT v) = ppr v pprParendType (ConT c) | c == ''[] = pprParendType ListT | c == ''(->) = pprParendType ArrowT | isTupleT (ConT c) = pprParendType (TupleT (length (nameBase c) - 1)) | otherwise = ppr c pprParendType (TupleT 0) = text "()" pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) pprParendType ArrowT = parens (text "->") pprParendType ListT = text "[]" pprParendType other = parens (ppr other) instance Ppr Type where ppr (ForallT tvars ctxt ty) = text "forall" <+> hsep (map ppr tvars) <+> text "." <+> pprCxt ctxt <+> ppr ty #if __GLASGOW_HASKELL__ >= 706 ppr StarT = text "*" #endif ppr ty = pprTyApp (split ty) pprTyApp :: (Type, [Type]) -> Doc pprTyApp (ArrowT, [arg1,arg2]) = sep [ppr arg1 <+> text "->", ppr arg2] pprTyApp (ListT, [arg]) = brackets (ppr arg) pprTyApp (TupleT n, args) | length args == n = parens (sep (punctuate comma (map ppr args))) pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args) split :: Type -> (Type, [Type]) -- Split into function and args split t = go t [] where go (AppT t1 t2) args = go t1 (t2:args) go ty args = (ty, args) ------------------------------ pprCxt :: Cxt -> Doc pprCxt [] = empty pprCxt [t] = ppr t <+> text "=>" pprCxt ts = parens (hsep $ punctuate comma $ map ppr ts) <+> text "=>" ------------------------------ instance Ppr Range where ppr = brackets . pprRange where pprRange :: Range -> Doc pprRange (FromR e) = ppr e <> text ".." pprRange (FromThenR e1 e2) = ppr e1 <> text "," <> ppr e2 <> text ".." pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2 pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text "," <> ppr e2 <> text ".." <> ppr e3 ------------------------------ where_clause :: [Dec] -> Doc where_clause [] = empty where_clause ds = nest nestDepth $ text "where" <+> vcat (map ppr ds) showtextl :: Show a => a -> Doc showtextl = text . map toLower . show #if __GLASGOW_HASKELL__ >= 612 instance Ppr TyVarBndr where ppr (PlainTV v) = ppr v ppr (KindedTV v k) = parens $ ppr v <+> text "::" <+> ppr k #if __GLASGOW_HASKELL__ < 706 instance Ppr Kind where ppr StarK = text "*" ppr (ArrowK j k) = ppr j <+> text "->" <+> ppr k #endif instance Ppr Pred where ppr (ClassP n ts) = ppr n <+> hsep (map ppr ts) ppr (EqualP t u ) = ppr t <+> text "~" <+> ppr u #endif derive-2.5.13/Language/Haskell/TH/ExpandSynonym.hs0000644000000000000000000000401112212421520020022 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- | Expand type synonyms in data declarations. -- -- This is needed for some type based derivations. module Language.Haskell.TH.ExpandSynonym (expandData) where import Language.Haskell.TH import Language.Haskell.TH.Compat import Language.Haskell.TH.Data import Data.Generics -- | Expand type synonyms in a data declaration expandData :: DataDef -> Q DataDef expandData = everywhereM (mkM expandType) expandType :: Type -> Q Type expandType t = expandType' t [] -- Walk over a type, collecting applied arguments expandType' :: Type -> [Type] -> Q Type expandType' (AppT t arg) args = expandType' t (arg:args) expandType' t@(ConT name) args = do result <- expandSyn name args case result of Just (t',args') -> everywhereM (mkM expandType) $ foldl AppT t' args' _ -> return $ foldl AppT t args expandType' t args = return $ foldl AppT t args -- Is the name a type synonym and are there enough arguments? if so, apply it expandSyn :: Name -> [Type] -> Q (Maybe (Type, [Type])) expandSyn name args = recover (return Nothing) $ do info <- reify name case info of TyConI (TySynD _ synArgs t) | length args >= length synArgs -> return $ Just (substitute (map fromTyVar synArgs) argsInst t, argsMore) -- instantiate type synonym where (argsInst,argsMore) = splitAt (length synArgs) args _ -> return Nothing -- `recover` return Nothing -- Substitute names for types in a type substitute :: [Name] -> [Type] -> Type -> Type substitute ns ts = subst (zip ns ts) where subst s (ForallT ns ctx t) = ForallT ns ctx (subst (filter ((`notElem` (map fromTyVar ns)) . fst) s) t) subst s (VarT n) | Just t' <- lookup n s = t' subst s (AppT a b) = AppT (subst s a) (subst s b) subst _ t = t derive-2.5.13/Language/Haskell/TH/Data.hs0000644000000000000000000000613012212421520016063 0ustar0000000000000000 -- | The core module of the Data.Derive system. This module contains -- the data types used for communication between the extractors and -- the derivors. module Language.Haskell.TH.Data where import Data.Char import Data.Generics import Language.Haskell.TH.Syntax import Language.Haskell.TH.Compat -- must be one of DataD or NewtypeD type DataDef = Dec type CtorDef = Con dataName :: DataDef -> String dataName (DataD _ name _ _ _) = unqualifiedName name dataName (NewtypeD _ name _ _ _) = unqualifiedName name qualifiedDataName :: DataDef -> Name qualifiedDataName (DataD _ name _ _ _) = name qualifiedDataName (NewtypeD _ name _ _ _) = name dataArity :: DataDef -> Int dataArity (DataD _ _ xs _ _) = length xs dataArity (NewtypeD _ _ xs _ _) = length xs dataArgs :: DataDef -> [Name] dataArgs = dataDefinitionTypeArgs dataCtors :: DataDef -> [CtorDef] dataCtors (DataD _ _ _ xs _) = xs dataCtors (NewtypeD _ _ _ x _) = [x] ctorName :: CtorDef -> String ctorName (NormalC name _ ) = unqualifiedName name ctorName (RecC name _ ) = unqualifiedName name ctorName (InfixC _ name _) = unqualifiedName name ctorName (ForallC _ _ c ) = ctorName c qualifiedCtorName :: CtorDef -> Name qualifiedCtorName (NormalC name _ ) = name qualifiedCtorName (RecC name _ ) = name qualifiedCtorName (InfixC _ name _) = name qualifiedCtorName (ForallC _ _ c ) = qualifiedCtorName c ctorArity :: CtorDef -> Int ctorArity (NormalC _ xs ) = length xs ctorArity (RecC _ xs ) = length xs ctorArity (InfixC _ _ _ ) = 2 ctorArity (ForallC _ _ c) = ctorArity c ctorStrictTypes :: CtorDef -> [StrictType] ctorStrictTypes (NormalC _ xs ) = xs ctorStrictTypes (RecC _ xs ) = [(b,c) | (a,b,c) <- xs] ctorStrictTypes (InfixC x _ y ) = [x,y] ctorStrictTypes (ForallC _ _ c) = ctorStrictTypes c ctorTypes :: CtorDef -> [Type] ctorTypes = map snd . ctorStrictTypes ctorFields :: CtorDef -> [String] ctorFields (RecC name varStrictType) = [unqualifiedName name | (name,strict,typ) <- varStrictType] ctorFields _ = [] -- normalisation -- make sure you deal with "GHC.Base.." dropModule :: String -> String dropModule xs = case reverse xs of ('.':xs) -> takeWhile (== '.') xs xs -> reverse $ takeWhile (/= '.') xs -- i_123432 -> i dropNumber :: String -> String dropNumber xs = if all isDigit a then reverse (tail b) else xs where (a,b) = break (== '_') $ reverse xs normData :: DataDef -> DataDef normData = everywhere (mkT normType) where normType :: Type -> Type normType (ConT x) | show x == "[]" = ListT normType x = x unqualifiedName :: Name -> String unqualifiedName = dropModule . show -- convert AppT chains back to a proper list typeApp :: Type -> (Type, [Type]) typeApp (AppT l r) = (a, b++[r]) where (a,b) = typeApp l typeApp t = (t, []) eqConT :: String -> Type -> Bool eqConT name (ConT x) = name == show x eqConT _ _ = False isTupleT :: Type -> Bool isTupleT (TupleT _) = True isTupleT (ConT x) = head sx == '(' && last sx == ')' && all (== ',') (take (length sx - 2) (tail sx)) where sx = nameBase x isTupleT _ = False derive-2.5.13/Language/Haskell/TH/Compat.hs0000644000000000000000000000160312212421520016435 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Compatibility definitions to paper over differences between 6.10 and 6.12. module Language.Haskell.TH.Compat where import Language.Haskell.TH #if __GLASGOW_HASKELL__ >= 612 fromTyVar :: TyVarBndr -> Name fromTyVar (PlainTV v) = v fromTyVar (KindedTV v _) = v #else fromTyVar :: Name -> Name fromTyVar v = v #endif dataDefinitionTypeArgs :: Dec -> [Name] #if __GLASGOW_HASKELL__ >= 612 dataDefinitionTypeArgs (DataD _cx name _ _ args) = args dataDefinitionTypeArgs (NewtypeD cx name _ _ args) = args #else dataDefinitionTypeArgs (DataD _cx name args cons _derv) = args dataDefinitionTypeArgs (NewtypeD cx name args con derv) = args #endif #if __GLASGOW_HASKELL__ >= 612 typeToPred :: Type -> Pred typeToPred (ConT v) = ClassP v [] typeToPred (AppT x y) = ClassP v (t++[y]) where ClassP v t = typeToPred x #else typeToPred :: Type -> Type typeToPred x = x #endif derive-2.5.13/Language/Haskell/TH/All.hs0000644000000000000000000000207712212421520015730 0ustar0000000000000000{-# OPTIONS_GHC -w #-} module Language.Haskell.TH.All ( module Language.Haskell.TH.All, module Language.Haskell.TH.Syntax, module Language.Haskell.TH.Peephole, module Language.Haskell.TH.Helper, module Language.Haskell.TH.FixedPpr, module Language.Haskell.TH.Data, module Language.Haskell.TH.ExpandSynonym, ) where import Language.Haskell.TH.Syntax import Language.Haskell.TH.Peephole import Language.Haskell.TH.Helper import Language.Haskell.TH.FixedPpr import Language.Haskell.TH.ExpandSynonym import Language.Haskell.TH.Data import Control.Monad -- | The type of ways to derive classes. -- Should not really be in this module! data Derivation = Derivation { derivationDeriver :: DataDef -> Q [Dec], -- ^ The derivation function proper derivationName :: String -- ^ The name of the derivation } -- create a new derivation more abstractly derivation :: (DataDef -> [Dec]) -> String -> Derivation derivation f = Derivation (return . f) derivationQ :: (DataDef -> Q [Dec]) -> String -> Derivation derivationQ = Derivation derive-2.5.13/Derive/0000755000000000000000000000000012212421520012453 5ustar0000000000000000derive-2.5.13/Derive/Utils.hs0000644000000000000000000000471412212421520014115 0ustar0000000000000000 module Derive.Utils where import Data.Derive.DSL.HSE import Data.List import qualified Data.ByteString.Char8 as BS import System.Directory import System.IO import System.FilePath import Control.Monad import Data.Maybe data Src = Src {srcName :: String ,srcImport :: [ImportDecl] ,srcExample :: Maybe [Decl] ,srcTest :: [(Type,[Decl])] ,srcCustom :: Bool } -- skip the importPkg bits srcImportStd :: Src -> [ImportDecl] srcImportStd y= [x{importPkg=Nothing} | x <- srcImport y] nullSrc = Src "" [] Nothing [] False readHSE :: FilePath -> IO Module readHSE file = do src <- readFile' file src <- return $ takeWhile (/= "-}") $ drop 1 $ dropWhile (/= "{-") $ dropWhile (not . isPrefixOf "module ") $ lines src let mode = defaultParseMode{extensions=map EnableExtension [MultiParamTypeClasses,FlexibleContexts,TemplateHaskell,PackageImports,TypeOperators]} return $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src data Pragma = Example Bool | Test Type asPragma :: Decl -> Maybe Pragma asPragma (TypeSig _ [x] t) | x ~= "example" = Just $ Example $ prettyPrint t == "Custom" | x ~= "test" = Just $ Test t asPragma _ = Nothing readSrc :: FilePath -> IO Src readSrc file = do modu <- readHSE file return $ foldl f nullSrc{srcName=takeBaseName file, srcImport=moduleImports modu} [ (p,xs) | p:real <- tails $ moduleDecls modu, Just p <- [asPragma p] , let xs = takeWhile (isNothing . asPragma) real ] where f src (Example x,bod) = src{srcExample = Just bod, srcCustom = x} f src (Test x,bod) = src{srcTest = srcTest src ++ [(x,bod)]} generatedStart = "-- GENERATED START" generatedStop = "-- GENERATED STOP" writeGenerated :: FilePath -> [String] -> IO () writeGenerated file x = do src <- fmap lines $ readFile' file let pre = takeWhile (/= generatedStart) src post = drop 1 $ dropWhile (/= generatedStop) src src2 = pre ++ [generatedStart] ++ x ++ [generatedStop] ++ post when (src /= src2) $ seq (length src2) $ writeBinaryFile file $ unlines src2 readFile' :: FilePath -> IO String readFile' file = do b <- doesFileExist file if b then fmap BS.unpack $ BS.readFile file else return [] writeBinaryFile :: FilePath -> String -> IO () writeBinaryFile file x = withBinaryFile file WriteMode (`hPutStr` x) rep from to x = if x == from then to else x reps from to = map (rep from to) derive-2.5.13/Derive/Test.hs0000644000000000000000000000743212212421520013734 0ustar0000000000000000 module Derive.Test(test) where import Derive.Utils import Data.Derive.DSL.HSE import Control.Monad import Data.Maybe import Data.List import System.FilePath import System.Cmd import System.Exit import Control.Arrow import Data.Derive.All import Data.Derive.Internal.Derivation -- These overlap with other derivations overlaps = [["BinaryDefer","EnumCyclic","LazySet","DataAbstract"] ,["Serialize"]] -- REASONS: -- UniplateDirect: Doesn't work through Template Haskell exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial"] -- These must be first and in every set priority = ["Eq","Typeable"] listType :: Decl listType = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"] [QualConDecl sl [] [] (ConDecl (Ident "[]") []) ,QualConDecl sl [] [] (ConDecl (Ident "Cons") [UnBangedTy (TyVar (Ident "a")) ,UnBangedTy (TyApp (TyCon (UnQual (Ident "List"))) (TyVar (Ident "a")))])] [] -- test each derivation test :: IO () test = do decls <- fmap (filter isDataDecl . moduleDecls) $ readHSE "Data/Derive/Internal/Test.hs" -- check the test bits let ts = ("[]",listType) : map (dataDeclName &&& id) decls mapM_ (testFile ts) derivations -- check the $(derive) bits putStrLn "Type checking examples" let name = "AutoGenerated_Test" devs <- sequence [liftM ((,) d) $ readSrc $ "Data/Derive" derivationName d <.> "hs" | d <- derivations] let lookupDev x = fromMaybe (error $ "Couldn't find derivation: " ++ x) $ find ((==) x . derivationName . fst) devs let sets = zip [1..] $ map (map lookupDev) $ map (priority++) $ [d | d <- map (derivationName . fst) devs, d `notElem` (exclude ++ priority ++ concat overlaps)] : overlaps forM sets $ \(i,xs) -> autoTest (name++show i) decls xs writeFile (name++".hs") $ unlines $ ["import " ++ name ++ show (fst i) | i <- sets] ++ ["main = putStrLn \"Type checking successful\""] res <- system $ "runhaskell " ++ name ++ ".hs" when (res /= ExitSuccess) $ error "Failed to typecheck results" testFile :: [(String,Decl)] -> Derivation -> IO () testFile types (Derivation name op) = do putStrLn $ "Testing " ++ name src <- readSrc $ "Data/Derive/" ++ name ++ ".hs" forM_ (srcTest src) $ \(typ,res) -> do let d = if tyRoot typ /= name then tyRoot typ else tyRoot $ head $ snd $ fromTyApps $ fromTyParen typ let grab x = fromMaybe (error $ "Error in tests, couldn't resolve type: " ++ x) $ lookup x types let Right r = op typ grab (ModuleName "Example", grab d) when (not $ r `outEq` res) $ error $ "Results don't match!\nExpected:\n" ++ showOut res ++ "\nGot:\n" ++ showOut r ++ "\n\n" ++ detailedNeq res r detailedNeq as bs | na /= nb = "Lengths don't match, " ++ show na ++ " vs " ++ show nb where na = length as ; nb = length bs detailedNeq as bs = "Mismatch on line " ++ show i ++ "\n" ++ show a ++ "\n" ++ show b where (i,a,b) = head $ filter (\(i,a,b) -> a /= b) $ zip3 [1..] (noSl as) (noSl bs) autoTest :: String -> [DataDecl] -> [(Derivation,Src)] -> IO () autoTest name ts ds = writeFile (name++".hs") $ unlines $ ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses,TypeOperators #-}" ,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields -fno-warn-unused-imports #-}" ,"module " ++ name ++ " where" ,"import Prelude" ,"import Data.DeriveTH" ,"import Derive.TestInstances()"] ++ [prettyPrint i | (_,s) <- ds, i <- srcImportStd s] ++ [prettyPrint t | t <- ts2] ++ ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | (d,_) <- ds] where types = "[" ++ intercalate "," ["''" ++ dataDeclName t | t <- ts2] ++ "]" ts2 = filter (not . isBuiltIn) ts isBuiltIn x = dataDeclName x `elem` ["Bool","Either"] derive-2.5.13/Derive/Main.hs0000644000000000000000000000400212212421520013667 0ustar0000000000000000 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 import System.Directory deriveMain :: [Derivation] -> IO () deriveMain derivations = do (flags,files) <- getFlags if Test `elem` flags then test else if Generate `elem` flags then generate else if Preprocessor `elem` flags then (if length files /= 3 then error $ "Expected to be invoked as a GHC preprocessor with 3 files, but got " ++ show (length files) else do copyFile (files !! 1) (files !! 2) mainFile derivations (Append:flags) (files !! 2) ) 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=defaultExtensions} 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 defaultExtensions :: [Extension] defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions badExtensions = [Arrows -- steals proc ,TransformListComp -- steals the group keyword ,XmlSyntax, RegularPatterns -- steals a-b ] derive-2.5.13/Derive/Generate.hs0000644000000000000000000001066312212421520014547 0ustar0000000000000000 module Derive.Generate(generate) where import Language.Haskell.Exts import Data.DeriveDSL import Derive.Utils import Control.Monad import Data.Maybe import System.FilePath import System.Directory import Data.Char import Data.List evil = words $ "TTypeable Uniplate" -- generate extra information for each derivation generate :: IO () generate = do xs <- getDirectoryContents "Data/Derive" xs <- return $ sort [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil] lis <- mapM generateFile $ map ("Data/Derive" ) xs let names = map dropExtension xs n = maximum $ map length names writeGenerated "Data/Derive/All.hs" $ ["import Data.Derive." ++ x ++ replicate (4 + n - length x) ' ' ++ "as D" | x <- names] ++ ["derivations :: [Derivation]" ,"derivations = [make" ++ concat (intersperse ",make" names) ++ "]"] writeGenerated "derive.htm" $ ["-->"] ++ lis ++ ["