derive-2.6.3/ 0000755 0000000 0000000 00000000000 13140114216 011157 5 ustar 00 0000000 0000000 derive-2.6.3/Setup.hs 0000644 0000000 0000000 00000000056 13140114216 012614 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
derive-2.6.3/README.md 0000644 0000000 0000000 00000025360 13140114216 012444 0 ustar 00 0000000 0000000 # Derive [](https://hackage.haskell.org/package/derive) [](https://travis-ci.org/ndmitchell/derive)
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:
* Obtaining and Installing Data.Derive
* Supported Derivations
* Using the Derive Program
* Using Template Haskell Derivations
* 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 howto add your own. Out of the box, we provide instances for the following libraries.
* **[Arbitrary](http://hackage.haskell.org/packages/archive/QuickCheck/latest/doc/html/Test-QuickCheck.html#t%3AArbitrary)** - from the library [QuickCheck](http://hackage.haskell.org/package/QuickCheck)
* **[ArbitraryOld](http://hackage.haskell.org/packages/archive/QuickCheck/1.2.0.0/doc/html/Test-QuickCheck.html#t%3AArbitraryOld)** - from the library [QuickCheck-1.2.0.0](http://hackage.haskell.org/package/QuickCheck-1.2.0.0)
* **[Arities](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Class-Arities.html#t%3AArities)** - from the library [derive](http://hackage.haskell.org/package/derive)
* **[Binary](http://hackage.haskell.org/packages/archive/binary/latest/doc/html/Data-Binary.html#t%3ABinary)** - from the library [binary](http://hackage.haskell.org/package/binary)
* **[BinaryDefer](http://hackage.haskell.org/packages/archive/binarydefer/latest/doc/html/Data-Binary-Defer.html#t%3ABinaryDefer)** - from the library [binarydefer](http://hackage.haskell.org/package/binarydefer)
* **[Bounded](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ABounded)** - from the library [base](http://hackage.haskell.org/package/base)
* **[DataAbstract](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Data.html#t%3ADataAbstract)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Default](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Class-Default.html#t%3ADefault)** - from the library [derive](http://hackage.haskell.org/package/derive)
* **[EnumCyclic](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEnum)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Fold](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Fold.html)**
* **[From](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-From.html)**
* **[Has](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Has.html)**
* **[Is](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Is.html)**
* **[JSON](http://hackage.haskell.org/packages/archive/json/latest/doc/html/Text-JSON.html#t%3AJSON)** - from the library [json](http://hackage.haskell.org/package/json)
* **[LazySet](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-LazySet.html)**
* **[Lens](http://hackage.haskell.org/packages/archive/data/lens/doc/html/Data-Lens-Common.html#t%3ALens)** - from the library [data-lens](http://hackage.haskell.org/package/data-lens)
* **[Monoid](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Monoid.html#t%3AMonoid)** - from the library [base](http://hackage.haskell.org/package/base)
* **[NFData](http://hackage.haskell.org/packages/archive/deepseq/latest/doc/html/Control-DeepSeq.html#t%3ANFData)** - from the library [deepseq](http://hackage.haskell.org/package/deepseq)
* **[Ref](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Ref.html)**
* **[Serial](http://hackage.haskell.org/packages/archive/smallcheck/latest/doc/html/Test-SmallCheck.html#t%3ASerial)** - from the library [smallcheck](http://hackage.haskell.org/package/smallcheck)
* **[Serialize](http://hackage.haskell.org/packages/archive/cereal/latest/doc/html/Data-Serialize.html#t%3ASerialize)** - from the library [cereal](http://hackage.haskell.org/package/cereal)
* **[Set](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Set.html)**
* **[UniplateDirect](http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-Uniplate-Direct.html#t%3AUniplateDirect)** - from the library [uniplate](http://hackage.haskell.org/package/uniplate)
* **[UniplateTypeable](http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-Uniplate-Typeable.html#t%3AUniplateTypeable)** - from the library [uniplate](http://hackage.haskell.org/package/uniplate)
* **[Update](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Update.html)**
## 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:
* Inductive - each derivation must be similar to the previous one. Binary does not have this property as a 1 item derivation does not have a tag, but a 2 item derivation does.
* Not inductive on the type - it must be an instance for the constructors, not for the type. Typeable violates this property by inducting on the free variables in the data type.
* Not type based - the derivation must not change based on the types of the fields. Play and Functor both behave differently given differently typed fields.
* Not record based - the derivation must not change on record fields. Show outputs the fields, so this is not allowed.
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.
### Modifying Derive
The standard sequence for testing Derive is:
$ ghci Main.hs
:main --generate
:reload
:main --test
The `--generate` option will automatically generate DSL's for derivations derived by example. The `--test` option runs all test comparisons and then loads the file with Template Haskell.
### Coding a new derivation
My best suggestion, start with a similar instance, i.e. to make `Eq2` from `Eq` do:
* Copy `Data/Derive/Eq.hs` to `Data/Derive/Eq2.hs`
* Rename some of the bits in `Eq2.hs` from `Eq`
* `ghci` -- load derive
* `:main` --generate -- this adds Eq2.hs to the .cabal/All.hs files etc
* `:reload` -- reload with Eq2.hs
Now fix up `Eq2.hs` appropriately.
derive-2.6.3/Main.hs 0000644 0000000 0000000 00000000166 13140114216 012402 0 ustar 00 0000000 0000000
module Main(main) where
import Data.Derive.All
import Data.DeriveMain
main :: IO ()
main = deriveMain derivations
derive-2.6.3/LICENSE 0000644 0000000 0000000 00000002764 13140114216 012175 0 ustar 00 0000000 0000000 Copyright Neil Mitchell 2006-2017.
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.6.3/derive.cabal 0000644 0000000 0000000 00000006250 13140114216 013424 0 ustar 00 0000000 0000000 cabal-version: >= 1.18
build-type: Default
name: derive
version: 2.6.3
build-type: Simple
copyright: Neil Mitchell 2006-2017
author: Neil Mitchell
maintainer: Neil Mitchell
homepage: https://github.com/ndmitchell/derive#readme
bug-reports: https://github.com/ndmitchell/derive/issues
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-doc-files:
README.md
CHANGES.txt
tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3
source-repository head
type: git
location: https://github.com/ndmitchell/derive.git
executable derive
default-language: Haskell2010
build-depends: base==4.* , derive
main-is: Main.hs
library
default-language: Haskell2010
hs-source-dirs: src
build-depends:
base == 4.*,
filepath, syb, template-haskell, containers, pretty,
directory, process, bytestring,
haskell-src-exts >= 1.18 && < 1.20,
transformers >= 0.2,
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.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.DataAbstract
Data.Derive.Default
Data.Derive.EnumCyclic
Data.Derive.Fold
Data.Derive.From
Data.Derive.Has
Data.Derive.Is
Data.Derive.JSON
Data.Derive.LazySet
Data.Derive.Lens
Data.Derive.Monoid
Data.Derive.NFData
Data.Derive.Ref
Data.Derive.Serial
Data.Derive.Serialize
Data.Derive.Set
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.6.3/CHANGES.txt 0000644 0000000 0000000 00000003642 13140114216 012775 0 ustar 00 0000000 0000000 Changelog for Derive
2.6.3
#24, support GHC 8.2
2.6.2
#19, more upgrade bug fixes
2.6.1
#19, allow haskell-src-exts-1.19
2.6
Remove lots of derivations that didn't seem useful (Eq, Show etc)
Change to use annotated Haskell syntax trees
Require haskell-src-exts-1.18
2.5.26
#17, fix incomplete pattern matches for certain types of data
2.5.25
#14, further GHC 8.0.1 updates
2.5.24
#14, update to GHC 8.0.1
#15, move all the source files under src to speed up building
Delete the FixedPpr module, was unused
2.5.23
Require haskell-src-exts-1.17
2.5.22
#7, #8 convert more types from TemplateHaskell
2.5.21
Fix the homepage link
2.5.20
#5, fix regression with higher-kinded constructors becoming context
2.5.19
Support GHC 7.10
2.5.18
#4, fix the read instance for nullary constructors
2.5.17
Upgrade to haskell-src-exts-1.16
Remove GHC 7.2 support
2.5.16
Allow transformers-0.4 and above
2.5.15
Allow haskell-src-exts-1.15.*
2.5.14
#3, support GHC 7.9
2.5.13
#622, turn on more Haskell extensions
2.5.12
Upgrade to haskell-src-exts-1.14.*
2.5.11
Support GHC 7.6
2.5.10
Add derivation for Lens
Modify the Typeable derivation to use mkTyCon3
2.5.9
Support the Template Haskell Unpacked constructor
2.5.8
Allow haskell-src-exts-1.13.*
2.5.7
Allow haskell-src-exts-1.12.*
2.5.6
Update the copyright year
Allow transformers-0.3.*
2.5.5
#513, allow derive to be run as a preprocessor
Improve the documentation for UniplateDirect
2.5.4
#394, allow tuple names in more places
Fix error when deriving Binary on "data A = B"
2.5.3
GHC 7.2 compatibility
2.5.2
Relax the dependency on haskell-src-exts to < 1.12
2.5.1
Improve documentation for deriveMain
2.5
#257, add Data.DeriveMain.deriveMain, to allow user derivations
2.4.2
Relax the dependency on haskell-src-exts to < 1.11
Start of changelog
derive-2.6.3/src/ 0000755 0000000 0000000 00000000000 13140114216 011746 5 ustar 00 0000000 0000000 derive-2.6.3/src/Language/ 0000755 0000000 0000000 00000000000 13140114216 013471 5 ustar 00 0000000 0000000 derive-2.6.3/src/Language/Haskell.hs 0000644 0000000 0000000 00000026777 13140114216 015433 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards #-}
module Language.Haskell(module Language.Haskell, module Language.Haskell.Exts) where
import Language.Haskell.Exts hiding (var,app,binds,paren,FieldDecl)
import qualified Language.Haskell.Exts as HSE
import Data.List
import Data.Generics.Uniplate.Data
import Data.Data
import Data.Char
import Data.Maybe
import Control.Arrow
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]) Nothing 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 :: Type () -> Bool
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 :: Exp () -> Exp ()
fExp (App _ op (List _ xs))
| op ~= "length" = Lit () $ Int () (fromIntegral $ length xs) (show $ 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) (show $ i-j)
| op ~= "+" = Lit () $ Int () (i + j) (show $ 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) (show $ 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:_ <- good = good
where good = [z | Alt _ (PLit _ Signless{} y) (UnGuardedRhs _ z) Nothing <- 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 :: Type () -> Type ()
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 :: Pat () -> Pat ()
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 () -> Match ()
fMatch (Match sl nam pat (GuardedRhss _ [GuardedRhs _ [Qualifier _ x] bod]) decls)
| x ~= "True" = fMatch $ Match sl nam pat (UnGuardedRhs () bod) decls
fMatch (Match sl nam [PVar _ x] (UnGuardedRhs _ (Case _ (Var _ (UnQual _ x2)) [Alt _ pat (UnGuardedRhs _ y) Nothing])) decls)
| x == x2 = fMatch $ Match sl nam [PParen () pat] (UnGuardedRhs () y) decls
fMatch o@(Match a b c d bind) = fBinds (Match a b (minPat o c) d) bind
fDecl :: Decl () -> Decl ()
fDecl (PatBind a b c bind) = fBinds (PatBind a b c) bind
fDecl (FunBind _ xs) = FunBind () $ filter (not . isGuardFalse) xs
fDecl x = x
fBinds context Nothing = context Nothing
fBinds context (Just (BDecls _ bind)) | inline /= [] =
simplify $ subst (Var () $ UnQual () from) to $ context $
let xs = take i bind ++ drop (i+1) bind in if null xs then Nothing else Just $ BDecls () xs
where
f (PatBind _ (PVar _ x) (UnGuardedRhs _ bod) Nothing) = [(x,bod)]
f (FunBind _ [Match _ x [PVar _ v] (UnGuardedRhs _ (Paren _ (App _ bod (Var _ v2)))) Nothing])
| UnQual () v == v2 = [(x,bod)]
f (FunBind _ [Match sl x pat (UnGuardedRhs _ bod) Nothing]) = [(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 $ Just $ 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 (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
isIdent (x:xs) = isAlpha x || x == '_'
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, Type ())]
type FullDataDecl = (ModuleName (), DataDecl)
moduleName (Module _ (Just (ModuleHead _ 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 () (pVar n) (UnGuardedRhs () e) Nothing
binds n xs = FunBind () [Match () (name n) p (UnGuardedRhs () e) Nothing | (p,e) <- xs]
isDataDecl :: Decl () -> Bool
isDataDecl DataDecl{} = True
isDataDecl GDataDecl{} = True
isDataDecl _ = False
dataDeclName :: DataDecl -> String
dataDeclName (DataDecl _ _ _ name _ _) = prettyPrint $ fst $ fromDeclHead name
dataDeclName (GDataDecl _ _ _ name _ _ _) = prettyPrint $ fst $ fromDeclHead name
fromDeclHead :: DeclHead a -> (Name a, [TyVarBind a])
fromDeclHead (DHead _ n) = (n, [])
fromDeclHead (DHInfix _ x n) = (n, [x])
fromDeclHead (DHParen _ x) = fromDeclHead x
fromDeclHead (DHApp _ dh x) = second (++[x]) $ fromDeclHead dh
fromIParen :: InstRule a -> InstRule a
fromIParen (IParen _ x) = fromIParen x
fromIParen x = x
fromInstHead :: InstHead a -> (QName a, [Type a])
fromInstHead (IHCon _ x) = (x, [])
fromInstHead (IHInfix _ t x) = (x, [t])
fromInstHead (IHParen _ x) = fromInstHead x
fromInstHead (IHApp l hd t) = second (++ [t]) $ fromInstHead hd
dataDeclVars :: DataDecl -> [String]
dataDeclVars (DataDecl _ _ _ hd _ _) = map f $ snd $ fromDeclHead hd
where f (KindedVar _ x _) = prettyPrint x
f (UnkindedVar _ x) = prettyPrint x
dataDeclVarsStar :: DataDecl -> [String]
dataDeclVarsStar (DataDecl _ _ _ hd _ _) = mapMaybe f $ snd $ fromDeclHead hd
where f (UnkindedVar _ x) = Just $ prettyPrint x
f (KindedVar _ x (KindStar _)) = Just $ prettyPrint x
f _ = Nothing
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) | HSE.FieldDecl _ as b <- fields, a <- as]
ctorDeclArity :: CtorDecl -> Int
ctorDeclArity = length . ctorDeclFields
declName :: Decl () -> String
declName (DataDecl _ _ _ name _ _) = prettyPrint $ fst $ fromDeclHead name
declName (GDataDecl _ _ _ name _ _ _) = prettyPrint $ fst $ fromDeclHead name
declName (TypeDecl _ name _) = prettyPrint $ fst $ fromDeclHead name
derive-2.6.3/src/Language/Haskell/ 0000755 0000000 0000000 00000000000 13140114216 015054 5 ustar 00 0000000 0000000 derive-2.6.3/src/Language/Haskell/Convert.hs 0000644 0000000 0000000 00000030554 13140114216 017037 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Language.Haskell.Convert(Convert, convert) where
import Language.Haskell as HS
import qualified Language.Haskell.Exts as HSE(FieldDecl(..))
import Language.Haskell.TH.Compat
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 :: TH.Type -> [TH.Type] -> TH.Type
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
#if __GLASGOW_HASKELL__ >= 800
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 :: DataOrNew () -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> unused -> HS.Decl ()
f t cxt n vs con _ = DataDecl () t (Just $ c cxt) (dh (c n) (c vs)) (c con) Nothing
#else
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 :: DataOrNew () -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> [TH.Name] -> HS.Decl ()
f t cxt n vs con ds = DataDecl () t (Just $ c cxt) (dh (c n) (c vs)) (c con) Nothing
#endif
dh name [] = DHead () name
dh name xs = DHApp () (dh name $ init xs) (last xs)
instance Convert TH.Cxt (HS.Context ()) where
conv = CxTuple () . map c
instance Convert (Maybe (HS.Context ())) TH.Cxt where
conv Nothing = []
conv (Just (CxSingle _ x)) = [c x]
conv (Just (CxTuple _ xs)) = map c xs
conv (Just (CxEmpty _)) = []
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 () (Just $ c vs) (Just $ c cxt) (c x)
conv x = QualConDecl () Nothing Nothing (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) [HSE.FieldDecl () [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.Type ()) where
#if __GLASGOW_HASKELL__ >= 800
conv (Bang SourceUnpack SourceStrict, x) = TyBang () (BangedTy ()) (Unpack ()) $ c x
conv (Bang SourceUnpack _, x) = TyBang () (NoStrictAnnot ()) (Unpack ()) $ c x
conv (Bang _ SourceStrict, x) = TyBang () (BangedTy ()) (NoUnpack ()) $ c x
conv (Bang _ _, x) = c x
#else
conv (IsStrict, x) = TyBang () (BangedTy ()) (NoUnpack ()) $ c x
conv (NotStrict, x) = c x
#if __GLASGOW_HASKELL__ >= 704
conv (Unpacked, x) = TyBang () (BangedTy ()) (Unpack ()) $ c x
#endif
#endif
instance Convert TH.Type (HS.Type ()) where
conv (ForallT xs cxt t) = TyForall () (Just $ c xs) (Just $ 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 (ArrowT) = TyCon () $ Special () $ FunCon ()
conv (AppT ListT x) = TyList () $ c x
conv (ListT) = TyCon () $ Special () $ ListCon ()
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 _ _ (fromIParen -> IRule _ _ cxt (fromInstHead -> (nam,typ))) ds) =
instanceD (c cxt) (c $ tyApp (TyCon () nam) typ) [c d | InsDecl _ d <- fromMaybe [] 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)
#if __GLASGOW_HASKELL__ >= 800
-- ! certainly BROKEN because it ignores contexts
conv (DataDecl _ DataType{} ctx (fromDeclHead -> (nam, typ)) cs ds) =
DataD (c ctx) (c nam) (c typ) Nothing (c cs) [] -- (c (map fst ds))
conv (DataDecl _ NewType{} ctx (fromDeclHead -> (nam, typ)) [con] ds) =
NewtypeD (c ctx) (c nam) (c typ) Nothing (c con) [] -- (c (map fst ds))
#else
conv (DataDecl _ DataType{} ctx (fromDeclHead -> (nam, typ)) cs ds) =
DataD (c ctx) (c nam) (c typ) (c cs) []
conv (DataDecl _ NewType{} ctx (fromDeclHead -> (nam, typ)) [con] ds) =
NewtypeD (c ctx) (c nam) (c typ) (c con) []
#endif
instance Convert (HS.QualConDecl ()) TH.Con where
conv (QualConDecl _ Nothing Nothing con) = c con
conv (QualConDecl _ vs cx con) = ForallC (c $ fromMaybe [] 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 (HSE.FieldDecl ()) [TH.VarStrictType] where
conv (HSE.FieldDecl _ names ty) = [(c name, bang, t) | let (bang,t) = c ty, name <- names]
instance Convert (HS.Type ()) TH.StrictType where
#if __GLASGOW_HASKELL__ >= 800
conv (TyBang _ BangedTy{} _ t) = (Bang NoSourceUnpackedness SourceStrict, c t)
#else
conv (TyBang _ BangedTy{} _ t) = (IsStrict, c t)
#if __GLASGOW_HASKELL__ >= 704
conv (TyBang _ _ Unpack{} t) = (Unpacked, c t)
#else
conv (TyBang _ _ Unpack{} t) = (IsStrict, c t)
#endif
#endif
#if __GLASGOW_HASKELL__ >= 800
conv t = (Bang NoSourceUnpackedness NoSourceStrictness, c t)
#else
conv t = (NotStrict, c t)
#endif
instance Convert ([HS.Name ()],HS.Type ()) [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 (GuardedRhs _ g x) = (conv g, conv x)
instance Convert [HS.Stmt ()] TH.Guard where
conv xs = PatG $ map conv xs
instance Convert (HS.Binds ()) [TH.Dec] where
conv (BDecls _ x) = c x
instance Convert (Maybe (HS.Binds ())) [TH.Dec] where
conv Nothing = []
conv (Just x) = c x
instance Convert (HS.Pat ()) TH.Pat where
conv (PParen _ x) = c x
conv (PLit _ Signless{} 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 (PFieldPat _ name pat) = (c name, c pat)
conv (PFieldPun _ name) = (c name, c $ PVar () $ Ident () $ prettyPrint name)
conv (PFieldWildcard _) = error "Can't convert PFieldWildcard"
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
#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
#if __GLASGOW_HASKELL__ < 709
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
#endif
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.6.3/src/Language/Haskell/TH/ 0000755 0000000 0000000 00000000000 13140114216 015367 5 ustar 00 0000000 0000000 derive-2.6.3/src/Language/Haskell/TH/Peephole.hs 0000644 0000000 0000000 00000013731 13140114216 017471 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards #-}
{-# OPTIONS_GHC -Wwarn #-}
{-
Otherwise I get:
src/Language/Haskell/TH/Peephole.hs:64:1: warning:
Pattern match checker exceeded (2000000) iterations in
an equation for ‘peep’. (Use -fmax-pmcheck-iterations=n
to set the maximun number of iterations to n)
Seriously. Your warning checker is crap. My code is fine.
Don't produce warnings about code I can't possibly fix.
Especially not by default.
-}
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.6.3/src/Language/Haskell/TH/Helper.hs 0000644 0000000 0000000 00000016256 13140114216 017154 0 ustar 00 0000000 0000000 {-# 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.6.3/src/Language/Haskell/TH/ExpandSynonym.hs 0000644 0000000 0000000 00000004011 13140114216 020533 0 ustar 00 0000000 0000000 {-# 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.6.3/src/Language/Haskell/TH/Data.hs 0000644 0000000 0000000 00000007244 13140114216 016603 0 ustar 00 0000000 0000000
-- | The core module of the Data.Derive system. This module contains
-- the data types used for communication between the extractors and
-- the derivors.
{-# language CPP #-}
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
#if __GLASGOW_HASKELL__ >= 800
dataName (DataD _ name _ _ _ _) = unqualifiedName name
dataName (NewtypeD _ name _ _ _ _) = unqualifiedName name
#else
dataName (DataD _ name _ _ _) = unqualifiedName name
dataName (NewtypeD _ name _ _ _) = unqualifiedName name
#endif
qualifiedDataName :: DataDef -> Name
#if __GLASGOW_HASKELL__ >= 800
qualifiedDataName (DataD _ name _ _ _ _) = name
qualifiedDataName (NewtypeD _ name _ _ _ _) = name
#else
qualifiedDataName (DataD _ name _ _ _) = name
qualifiedDataName (NewtypeD _ name _ _ _) = name
#endif
dataArity :: DataDef -> Int
#if __GLASGOW_HASKELL__ >= 800
dataArity (DataD _ _ xs _ _ _) = length xs
dataArity (NewtypeD _ _ xs _ _ _) = length xs
#else
dataArity (DataD _ _ xs _ _) = length xs
dataArity (NewtypeD _ _ xs _ _) = length xs
#endif
dataArgs :: DataDef -> [Name]
dataArgs = dataDefinitionTypeArgs
dataCtors :: DataDef -> [CtorDef]
#if __GLASGOW_HASKELL__ >= 800
dataCtors (DataD _ _ _ _ xs _) = xs
dataCtors (NewtypeD _ _ _ _ x _) = [x]
#else
dataCtors (DataD _ _ _ xs _) = xs
dataCtors (NewtypeD _ _ _ x _) = [x]
#endif
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.6.3/src/Language/Haskell/TH/Compat.hs 0000644 0000000 0000000 00000003051 13140114216 017145 0 ustar 00 0000000 0000000 {-# 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
#if __GLASGOW_HASKELL__ >= 800
instanceD = InstanceD Nothing
#else
instanceD = InstanceD
#endif
dataDefinitionTypeArgs :: Dec -> [Name]
#if __GLASGOW_HASKELL__ >= 802
dataDefinitionTypeArgs (DataD _ _ _ _ _ deriv_clauses) =
deriv_clauses >>= from_deriv_clause
dataDefinitionTypeArgs (NewtypeD _ _ _ _ _ deriv_clauses) =
deriv_clauses >>= from_deriv_clause
from_deriv_clause :: DerivClause -> [Name]
from_deriv_clause (DerivClause _ cxt) = map from_cxt cxt
#elif __GLASGOW_HASKELL__ >= 800
dataDefinitionTypeArgs (DataD _cx name _ _ _ cxt) = map from_cxt cxt
dataDefinitionTypeArgs (NewtypeD cx name _ _ _ cxt) = map from_cxt cxt
#elif __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
from_cxt :: Type -> Name
from_cxt (ConT name) = name
#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 709
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.6.3/src/Language/Haskell/TH/All.hs 0000644 0000000 0000000 00000001766 13140114216 016445 0 ustar 00 0000000 0000000 {-# 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.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.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.6.3/src/Derive/ 0000755 0000000 0000000 00000000000 13140114216 013164 5 ustar 00 0000000 0000000 derive-2.6.3/src/Derive/Utils.hs 0000644 0000000 0000000 00000004772 13140114216 014632 0 ustar 00 0000000 0000000
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 $ fmap (const ()) $ 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.6.3/src/Derive/Test.hs 0000644 0000000 0000000 00000010000 13140114216 014426 0 ustar 00 0000000 0000000
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.Process
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
-- Typeable cannot be separately derived in GHC 7.8
exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial","Binary","Typeable"]
-- These must be first and in every set
priority = []
listType :: Decl ()
listType = DataDecl () (DataType ()) Nothing (DHApp () (DHead () (Ident () "[]")) (UnkindedVar () $ Ident () "a"))
[QualConDecl () Nothing Nothing (ConDecl () (Ident () "[]") [])
,QualConDecl () Nothing Nothing (ConDecl () (Ident () "Cons")
[TyVar () (Ident () "a")
,TyApp () (TyCon () (UnQual () (Ident () "List"))) (TyVar () (Ident () "a"))])]
Nothing
-- 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 -isrc " ++ 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,DeriveDataTypeable #-}"
,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields -fno-warn-unused-imports #-}"
,"module " ++ name ++ " where"
,"import Prelude"
,"import Data.DeriveTH"
,"import Data.Typeable"
,"import Derive.TestInstances()"] ++
[prettyPrint i | (_,s) <- ds, i <- srcImportStd s] ++
[prettyPrint t ++ "\n deriving Typeable" | 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.6.3/src/Derive/Main.hs 0000644 0000000 0000000 00000004154 13140114216 014410 0 ustar 00 0000000 0000000
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 :: Module SrcSpanInfo
flags <- return $ foldl addFlags flags
[(getPointLoc sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine]
let blur = fmap (const ())
let res = performDerive derivations (blur mine :: Module ()) $ wantDerive flags (blur real) (blur mine)
writeDerive file (moduleName $ blur 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.6.3/src/Derive/Generate.hs 0000644 0000000 0000000 00000010626 13140114216 015257 0 ustar 00 0000000 0000000
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 "src/Data/Derive"
xs <- return $ sort [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]
lis <- mapM generateFile $ map ("src/Data/Derive" ) xs
let names = map dropExtension xs
n = maximum $ map length names
writeGenerated "src/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 "README.md" $ ["-->",""] ++ lis ++ ["","