derive-2.5.26/ 0000755 0000000 0000000 00000000000 12732050546 011256 5 ustar 00 0000000 0000000 derive-2.5.26/Setup.hs 0000644 0000000 0000000 00000000056 12732050546 012713 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
derive-2.5.26/README.md 0000644 0000000 0000000 00000030665 12732050546 012547 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)
* **[Data](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Data.html#t%3AData)** - 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)
* **[Enum](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEnum)** - from the library [base](http://hackage.haskell.org/package/base)
* **[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)
* **[Eq](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEq)** - 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)**
* **[Foldable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Foldable.html#t%3AFoldable)** - from the library [base](http://hackage.haskell.org/package/base)
* **[From](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-From.html)**
* **[Functor](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AFunctor)** - from the library [base](http://hackage.haskell.org/package/base)
* **[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)
* **[Ord](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AOrd)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Read](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ARead)** - from the library [base](http://hackage.haskell.org/package/base)
* **[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)**
* **[Show](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AShow)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Traversable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Traversable.html#t%3ATraversable)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Typeable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Typeable.html#t%3ATypeable)** - from the library [base](http://hackage.haskell.org/package/base)
* **[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.5.26/Main.hs 0000644 0000000 0000000 00000000166 12732050546 012501 0 ustar 00 0000000 0000000
module Main(main) where
import Data.Derive.All
import Data.DeriveMain
main :: IO ()
main = deriveMain derivations
derive-2.5.26/LICENSE 0000644 0000000 0000000 00000002764 12732050546 012274 0 ustar 00 0000000 0000000 Copyright Neil Mitchell 2006-2016.
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.26/derive.cabal 0000644 0000000 0000000 00000006541 12732050546 013526 0 ustar 00 0000000 0000000 cabal-version: >= 1.8
build-type: Default
name: derive
version: 2.5.26
build-type: Simple
copyright: Neil Mitchell 2006-2016
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.0.1, 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
build-depends: base==4.* , derive
main-is: Main.hs
library
hs-source-dirs: src
build-depends:
base == 4.*,
filepath, syb, template-haskell, containers, pretty,
directory, process, bytestring,
haskell-src-exts >= 1.17 && < 1.18,
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.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.26/CHANGES.txt 0000644 0000000 0000000 00000003225 12732050546 013071 0 ustar 00 0000000 0000000 Changelog for Derive
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.5.26/src/ 0000755 0000000 0000000 00000000000 12732050546 012045 5 ustar 00 0000000 0000000 derive-2.5.26/src/Language/ 0000755 0000000 0000000 00000000000 12732050546 013570 5 ustar 00 0000000 0000000 derive-2.5.26/src/Language/Haskell.hs 0000644 0000000 0000000 00000024345 12732050546 015517 0 ustar 00 0000000 0000000
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
import Data.Maybe
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 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 (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 (UnGuardedRhs y) Nothing])) 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 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] Nothing (UnGuardedRhs (Paren (App bod (Var v2)))) Nothing])
| UnQual v == v2 = [(x,bod)]
f (FunBind [Match sl x pat Nothing (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 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
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 _ 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) (UnGuardedRhs e) Nothing
binds n xs = FunBind [Match sl (name n) p Nothing (UnGuardedRhs e) Nothing | (p,e) <- xs]
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 f vars
where f (KindedVar x _) = prettyPrint x
f (UnkindedVar x) = prettyPrint x
dataDeclVarsStar :: DataDecl -> [String]
dataDeclVarsStar (DataDecl _ _ _ _ vars _ _) = mapMaybe f vars
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) | (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.26/src/Language/Haskell/ 0000755 0000000 0000000 00000000000 12732050546 015153 5 ustar 00 0000000 0000000 derive-2.5.26/src/Language/Haskell/Convert.hs 0000644 0000000 0000000 00000025163 12732050546 017136 0 ustar 00 0000000 0000000 {-# 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 Language.Haskell.TH.Compat
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 sl t (c cxt) (c n) (c vs) (c con) []
#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 sl t (c cxt) (c n) (c vs) (c con) []
#endif
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.Type where
#if __GLASGOW_HASKELL__ >= 800
conv (Bang SourceUnpack SourceStrict, x) = TyBang UnpackedTy $ TyBang BangedTy $ c x
conv (Bang SourceUnpack _, x) = TyBang UnpackedTy $ c x
conv (Bang _ SourceStrict, x) = TyBang BangedTy $ c x
conv (Bang _ _, x) = c x
#else
conv (IsStrict, x) = TyBang BangedTy $ c x
conv (NotStrict, x) = c x
#if __GLASGOW_HASKELL__ >= 704
conv (Unpacked, x) = TyBang UnpackedTy $ c x
#endif
#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 (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 _ _ _ 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)
#if __GLASGOW_HASKELL__ >= 800
-- ! certainly BROKEN because it ignores contexts
conv (DataDecl _ DataType ctx nam typ cs ds) =
DataD (c ctx) (c nam) (c typ) Nothing (c cs) [] -- (c (map fst ds))
conv (DataDecl _ NewType ctx nam typ [con] ds) =
NewtypeD (c ctx) (c nam) (c typ) Nothing (c con) [] -- (c (map fst ds))
#else
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))
#endif
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.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 UnpackedTy t) = (Unpacked, c t)
#else
conv (TyBang UnpackedTy 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 = undefined
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 = 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
#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.5.26/src/Language/Haskell/TH/ 0000755 0000000 0000000 00000000000 12732050546 015466 5 ustar 00 0000000 0000000 derive-2.5.26/src/Language/Haskell/TH/Peephole.hs 0000644 0000000 0000000 00000013731 12732050546 017570 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.5.26/src/Language/Haskell/TH/Helper.hs 0000644 0000000 0000000 00000016256 12732050546 017253 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.5.26/src/Language/Haskell/TH/ExpandSynonym.hs 0000644 0000000 0000000 00000004011 12732050546 020632 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.5.26/src/Language/Haskell/TH/Data.hs 0000644 0000000 0000000 00000007244 12732050546 016702 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.5.26/src/Language/Haskell/TH/Compat.hs 0000644 0000000 0000000 00000002361 12732050546 017247 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__ >= 800
dataDefinitionTypeArgs (DataD _cx name _ _ _ cxt) = map from_cxt cxt
dataDefinitionTypeArgs (NewtypeD cx name _ _ _ cxt) = map from_cxt cxt
#else
#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
#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.5.26/src/Language/Haskell/TH/All.hs 0000644 0000000 0000000 00000001766 12732050546 016544 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.5.26/src/Derive/ 0000755 0000000 0000000 00000000000 12732050546 013263 5 ustar 00 0000000 0000000 derive-2.5.26/src/Derive/Utils.hs 0000644 0000000 0000000 00000004714 12732050546 014725 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 $ 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.26/src/Derive/Test.hs 0000644 0000000 0000000 00000007625 12732050546 014550 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 = ["Eq"]
listType :: Decl
listType = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"]
[QualConDecl sl [] [] (ConDecl (Ident "[]") [])
,QualConDecl sl [] [] (ConDecl (Ident "Cons")
[TyVar (Ident "a")
,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 -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.5.26/src/Derive/Main.hs 0000644 0000000 0000000 00000004002 12732050546 014477 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
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.26/src/Derive/Generate.hs 0000644 0000000 0000000 00000010602 12732050546 015350 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 ++ ["","