derive-2.6.5/ 0000755 0000000 0000000 00000000000 07346545000 011173 5 ustar 00 0000000 0000000 derive-2.6.5/CHANGES.txt 0000644 0000000 0000000 00000004012 07346545000 013001 0 ustar 00 0000000 0000000 2.6.4
Rewrite for haskell-src-exts == 1.20.*
#27, disable a few more extensions by default (sync with the HLint list)
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.5/LICENSE 0000644 0000000 0000000 00000002764 07346545000 012211 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.5/Main.hs 0000644 0000000 0000000 00000000166 07346545000 012416 0 ustar 00 0000000 0000000
module Main(main) where
import Data.Derive.All
import Data.DeriveMain
main :: IO ()
main = deriveMain derivations
derive-2.6.5/README.md 0000644 0000000 0000000 00000026052 07346545000 012457 0 ustar 00 0000000 0000000 # Derive [](https://hackage.haskell.org/package/derive) [](https://travis-ci.org/ndmitchell/derive)
**Warning: This package has no official maintainer anymore. Use at your own risk. You may wish to consider the built-in mechanism [`GHC.Generics`](https://hackage.haskell.org/package/base-4.11.1.0/docs/GHC-Generics.html) or libraries such as [`generic-deriving`](https://hackage.haskell.org/package/generic-deriving).**
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.5/Setup.hs 0000644 0000000 0000000 00000000056 07346545000 012630 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
derive-2.6.5/derive.cabal 0000644 0000000 0000000 00000006160 07346545000 013440 0 ustar 00 0000000 0000000 cabal-version: 1.18
build-type: Simple
name: derive
version: 2.6.5
copyright: Neil Mitchell 2006-2017
author: Neil Mitchell and others
maintainer: None
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.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.5/src/Data/Derive/ 0000755 0000000 0000000 00000000000 07346545000 014051 5 ustar 00 0000000 0000000 derive-2.6.5/src/Data/Derive/All.hs 0000644 0000000 0000000 00000003227 07346545000 015121 0 ustar 00 0000000 0000000 -- | This module provides convenience re-exports of all the standard
-- Data.Derive derivations.
module Data.Derive.All (Derivation, derivations, module D) where
import Data.Derive.Internal.Derivation
-- GENERATED START
import Data.Derive.Arbitrary as D
import Data.Derive.ArbitraryOld as D
import Data.Derive.Arities as D
import Data.Derive.Binary as D
import Data.Derive.BinaryDefer as D
import Data.Derive.Bounded as D
import Data.Derive.DataAbstract as D
import Data.Derive.Default as D
import Data.Derive.EnumCyclic as D
import Data.Derive.Fold as D
import Data.Derive.From as D
import Data.Derive.Has as D
import Data.Derive.Is as D
import Data.Derive.JSON as D
import Data.Derive.LazySet as D
import Data.Derive.Lens as D
import Data.Derive.Monoid as D
import Data.Derive.NFData as D
import Data.Derive.Ref as D
import Data.Derive.Serial as D
import Data.Derive.Serialize as D
import Data.Derive.Set as D
import Data.Derive.UniplateDirect as D
import Data.Derive.UniplateTypeable as D
import Data.Derive.Update as D
derivations :: [Derivation]
derivations = [makeArbitrary,makeArbitraryOld,makeArities,makeBinary,makeBinaryDefer,makeBounded,makeDataAbstract,makeDefault,makeEnumCyclic,makeFold,makeFrom,makeHas,makeIs,makeJSON,makeLazySet,makeLens,makeMonoid,makeNFData,makeRef,makeSerial,makeSerialize,makeSet,makeUniplateDirect,makeUniplateTypeable,makeUpdate]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/Arbitrary.hs 0000644 0000000 0000000 00000012364 07346545000 016352 0 ustar 00 0000000 0000000 module Data.Derive.Arbitrary(makeArbitrary) where
{-
import "QuickCheck" Test.QuickCheck
example :: Custom
instance Arbitrary (Sample a) where
arbitrary = do
x <- choose (0::Int,length [First{},Second{},Third{}] - 1)
case x of
0 -> do return (First)
1 -> do x1 <- arbitrary
x2 <- arbitrary
return (Second x1 x2)
2 -> do x1 <- arbitrary
return (Third x1)
_ -> error "FATAL ERROR: Arbitrary instance, logic bug"
test :: State
instance (CoArbitrary s, Arbitrary s, Arbitrary a) => Arbitrary (State s a) where
arbitrary = do x1 <- arbitrary
return (StateT x1)
-}
import Data.Derive.DSL.HSE
import Data.List
import Data.Generics.Uniplate.DataOnly
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeArbitrary :: Derivation
makeArbitrary = derivationCustomDSL "Arbitrary" custom $
List [Instance [] "Arbitrary" (App "Just" (List [List [App
"InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"
(List []),App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),String "arbitrary"])]),App "UnGuardedRhs" (List
[App "()" (List []),App "Do" (List [App "()" (List []),List [App
"Generator" (List [App "()" (List []),App "PVar" (List [App "()" (
List []),App "Ident" (List [App "()" (List []),String "x"])]),App
"App" (List [App "()" (List []),App "Var" (List [App "()" (List []
),App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),String "choose"])])]),App "Tuple" (List [App "()" (
List []),App "Boxed" (List []),List [App "ExpTypeSig" (List [App
"()" (List []),App "Lit" (List [App "()" (List []),App "Int" (List
[App "()" (List []),Int 0,ShowInt (Int 0)])]),App "TyCon" (List [
App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "Int"])])])]),App
"InfixApp" (List [App "()" (List []),App "App" (List [App "()" (
List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"length"])])]),App "List" (List [App "()" (List []),MapCtor (App
"RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"
(List []),App "Ident" (List [App "()" (List []),CtorName])]),List
[]]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual" (
List [App "()" (List []),App "Symbol" (List [App "()" (List []),
String "-"])])]),App "Lit" (List [App "()" (List []),App "Int" (
List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]])])]),App
"Qualifier" (List [App "()" (List []),App "Case" (List [App "()" (
List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"x"])])]),Concat (List [MapCtor (App "Alt" (List [App "()" (List [
]),App "PLit" (List [App "()" (List []),App "Signless" (List [App
"()" (List [])]),App "Int" (List [App "()" (List []),CtorIndex,
ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()" (List [])
,App "Do" (List [App "()" (List []),Concat (List [MapField (App
"Generator" (List [App "()" (List []),App "PVar" (List [App "()" (
List []),App "Ident" (List [App "()" (List []),Concat (List [
String "x",ShowInt FieldIndex])])]),App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "arbitrary"])])])])),List [App
"Qualifier" (List [App "()" (List []),App "App" (List [App "()" (
List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"return"])])]),App "Paren" (List [App "()" (List []),Application (
Concat (List [List [App "Con" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),CtorName])])])],MapField (App "Var" (List [App "()" (List
[]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])
)]))])])])]])])]),App "Nothing" (List [])])),List [App "Alt" (List
[App "()" (List []),App "PWildCard" (List [App "()" (List [])]),
App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App
"()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (
List [App "()" (List []),App "Ident" (List [App "()" (List []),
String "error"])])]),App "Lit" (List [App "()" (List []),App
"String" (List [App "()" (List []),String
"FATAL ERROR: Arbitrary instance, logic bug",String
"FATAL ERROR: Arbitrary instance, logic bug"])])])]),App "Nothing"
(List [])])]])])])]])]),App "Nothing" (List [])])])]]))]
-- GENERATED STOP
custom = customContext context
-- Fix the context
-- C a b => Arbitrary a, Arbitrary b
-- a -> b => CoArbitrary a, Arbitrary b
context :: FullDataDecl -> Context () -> Context ()
context (_,d) _ = CxTuple () $ nub $ concatMap (f True . snd) $ concatMap ctorDeclFields $ dataDeclCtors d
where
f b (TyVar _ x) = [ClassA () (qname $ b ? "Arbitrary" $ "CoArbitrary") [TyVar () x]]
f b (TyFun _ x y) = f (not b) x ++ f b y
f b x = concatMap (f b) (children x)
derive-2.6.5/src/Data/Derive/ArbitraryOld.hs 0000644 0000000 0000000 00000011165 07346545000 017007 0 ustar 00 0000000 0000000 module Data.Derive.ArbitraryOld where
{-
import "QuickCheck-1.2.0.0" Test.QuickCheck(Arbitrary(..), choose,variant)
example :: Sample
instance Arbitrary a => Arbitrary (Sample a) where
arbitrary = do
x <- choose (0,length [First{},Second{},Third{}]-1)
case x of
0 -> do return (First)
1 -> do x1 <- arbitrary
x2 <- arbitrary
return (Second x1 x2)
2 -> do x1 <- arbitrary
return (Third x1)
coarbitrary (First) = ()
coarbitrary (Second x1 x2) = ()
coarbitrary (Third x1) = ()
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeArbitraryOld :: Derivation
makeArbitraryOld = derivationDSL "ArbitraryOld" dslArbitraryOld
dslArbitraryOld =
List [Instance ["Arbitrary"] "Arbitrary" (App "Just" (List [List [
App "InsDecl" (List [App "()" (List []),App "PatBind" (List [App
"()" (List []),App "PVar" (List [App "()" (List []),App "Ident" (
List [App "()" (List []),String "arbitrary"])]),App "UnGuardedRhs"
(List [App "()" (List []),App "Do" (List [App "()" (List []),List
[App "Generator" (List [App "()" (List []),App "PVar" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),String "x"])]
),App "App" (List [App "()" (List []),App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "choose"])])]),App "Tuple" (List [App
"()" (List []),App "Boxed" (List []),List [App "Lit" (List [App
"()" (List []),App "Int" (List [App "()" (List []),Int 0,ShowInt (
Int 0)])]),App "InfixApp" (List [App "()" (List []),App "App" (
List [App "()" (List []),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "length"])])]),App "List" (List [App "()" (List []
),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"
(List [App "()" (List []),App "Ident" (List [App "()" (List []),
CtorName])]),List []]))])]),App "QVarOp" (List [App "()" (List [])
,App "UnQual" (List [App "()" (List []),App "Symbol" (List [App
"()" (List []),String "-"])])]),App "Lit" (List [App "()" (List []
),App "Int" (List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]
])])]),App "Qualifier" (List [App "()" (List []),App "Case" (List
[App "()" (List []),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "x"])])]),MapCtor (App "Alt" (List [App "()" (List
[]),App "PLit" (List [App "()" (List []),App "Signless" (List [App
"()" (List [])]),App "Int" (List [App "()" (List []),CtorIndex,
ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()" (List [])
,App "Do" (List [App "()" (List []),Concat (List [MapField (App
"Generator" (List [App "()" (List []),App "PVar" (List [App "()" (
List []),App "Ident" (List [App "()" (List []),Concat (List [
String "x",ShowInt FieldIndex])])]),App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "arbitrary"])])])])),List [App
"Qualifier" (List [App "()" (List []),App "App" (List [App "()" (
List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"return"])])]),App "Paren" (List [App "()" (List []),Application (
Concat (List [List [App "Con" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),CtorName])])])],MapField (App "Var" (List [App "()" (List
[]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])
)]))])])])]])])]),App "Nothing" (List [])]))])])]])]),App
"Nothing" (List [])])]),App "InsDecl" (List [App "()" (List []),
App "FunBind" (List [App "()" (List []),MapCtor (App "Match" (List
[App "()" (List []),App "Ident" (List [App "()" (List []),String
"coarbitrary"]),List [App "PParen" (List [App "()" (List []),App
"PApp" (List [App "()" (List []),App "UnQual" (List [App "()" (
List []),App "Ident" (List [App "()" (List []),CtorName])]),
MapField (App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])
]))])])],App "UnGuardedRhs" (List [App "()" (List []),App "Con" (
List [App "()" (List []),App "Special" (List [App "()" (List []),
App "UnitCon" (List [App "()" (List [])])])])]),App "Nothing" (
List [])]))])])]]))]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/Arities.hs 0000644 0000000 0000000 00000002702 07346545000 016006 0 ustar 00 0000000 0000000 module Data.Derive.Arities where
{-
import "derive" Data.Derive.Class.Arities
example :: Sample
instance Arities (Sample a) where
arities _ = [const 0 First{}, const 2 Second{}, const 1 Third{}]
test :: []
instance Arities [a] where
arities _ = [0,2]
test :: Bool
instance Arities Bool where
arities _ = [0,0]
test :: Either
instance Arities (Either a b) where
arities _ = [1,1]
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeArities :: Derivation
makeArities = derivationDSL "Arities" dslArities
dslArities =
List [Instance [] "Arities" (App "Just" (List [List [App "InsDecl"
(List [App "()" (List []),App "FunBind" (List [App "()" (List []),
List [App "Match" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),String "arities"]),List [App "PWildCard" (List [App
"()" (List [])])],App "UnGuardedRhs" (List [App "()" (List []),App
"List" (List [App "()" (List []),MapCtor (Application (List [App
"Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "const"])])]),App
"Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []
),CtorArity,ShowInt CtorArity])]),App "RecConstr" (List [App "()"
(List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),CtorName])]),List []])]))])]),App "Nothing" (
List [])])]])])]]))]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/Binary.hs 0000644 0000000 0000000 00000023350 07346545000 015634 0 ustar 00 0000000 0000000 module Data.Derive.Binary where
{-
import "binary" Data.Binary
example :: Sample
instance Binary alpha => Binary (Sample alpha) where
put x = case x of
First -> do putTag 0
Second x1 x2 -> do putTag 1 ; put x1 ; put x2
Third x1 -> do putTag 2 ; put x1
where
useTag = length [First{}, Second{}, Third{}] > 1
putTag x = when useTag (putWord8 x)
get = do
i <- getTag
case i of
0 -> do return (First)
1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)
2 -> do x1 <- get ; return (Third x1)
_ -> error "Corrupted binary data for Sample"
where
useTag = length [First{}, Second{}, Third{}] > 1
getTag = if useTag then getWord8 else return 0
test :: List
instance Binary a => Binary (List a) where
put x = case x of
Nil -> putWord8 0
Cons x1 x2 -> do putWord8 1; put x1; put x2
get = do
i <- getWord8
case i of
0 -> return Nil
1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)
_ -> error "Corrupted binary data for List"
test :: Assoced
instance Binary typ => Binary (Assoced typ) where
put (Assoced x1 x2) = do put x1; put x2
get = do x1 <- get; x2 <- get; return (Assoced x1 x2)
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeBinary :: Derivation
makeBinary = derivationDSL "Binary" dslBinary
dslBinary =
List [Instance ["Binary"] "Binary" (App "Just" (List [List [App
"InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"
(List []),List [App "Match" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),String "put"]),List [App "PVar" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"x"])])],App "UnGuardedRhs" (List [App "()" (List []),App "Case" (
List [App "()" (List []),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "x"])])]),MapCtor (App "Alt" (List [App "()" (List
[]),App "PApp" (List [App "()" (List []),App "UnQual" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),CtorName])]),
MapField (App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])
]))]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (List
[App "()" (List []),Concat (List [List [App "Qualifier" (List [App
"()" (List []),App "App" (List [App "()" (List []),App "Var" (List
[App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "putTag"])])]),App "Lit"
(List [App "()" (List []),App "Int" (List [App "()" (List []),
CtorIndex,ShowInt CtorIndex])])])])],MapField (App "Qualifier" (
List [App "()" (List []),App "App" (List [App "()" (List []),App
"Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "put"])])]),App
"Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),Concat (List [String "x"
,ShowInt FieldIndex])])])])])]))])])]),App "Nothing" (List [])]))]
)]),App "Just" (List [App "BDecls" (List [App "()" (List []),List
[App "PatBind" (List [App "()" (List []),App "PVar" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),String
"useTag"])]),App "UnGuardedRhs" (List [App "()" (List []),App
"InfixApp" (List [App "()" (List []),App "App" (List [App "()" (
List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"length"])])]),App "List" (List [App "()" (List []),MapCtor (App
"RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"
(List []),App "Ident" (List [App "()" (List []),CtorName])]),List
[]]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual" (
List [App "()" (List []),App "Symbol" (List [App "()" (List []),
String ">"])])]),App "Lit" (List [App "()" (List []),App "Int" (
List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]),App
"Nothing" (List [])]),App "FunBind" (List [App "()" (List []),List
[App "Match" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),String "putTag"]),List [App "PVar" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "x"])])],App
"UnGuardedRhs" (List [App "()" (List []),Application (List [App
"Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "when"])])]),App
"Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "useTag"])])]),
App "Paren" (List [App "()" (List []),App "App" (List [App "()" (
List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),Concat (
List [String "putWord",ShowInt (Int 8)])])])]),App "Var" (List [
App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "x"])])])])])])]),App
"Nothing" (List [])])]])]])])])]])]),App "InsDecl" (List [App "()"
(List []),App "PatBind" (List [App "()" (List []),App "PVar" (List
[App "()" (List []),App "Ident" (List [App "()" (List []),String
"get"])]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (
List [App "()" (List []),List [App "Generator" (List [App "()" (
List []),App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),String "i"])]),App "Var" (List [App "()" (List
[]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),String "getTag"])])])]),App "Qualifier" (List [App
"()" (List []),App "Case" (List [App "()" (List []),App "Var" (
List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),String "i"])])]),Concat (
List [MapCtor (App "Alt" (List [App "()" (List []),App "PLit" (
List [App "()" (List []),App "Signless" (List [App "()" (List [])]
),App "Int" (List [App "()" (List []),CtorIndex,ShowInt CtorIndex]
)]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (List [
App "()" (List []),Concat (List [MapField (App "Generator" (List [
App "()" (List []),App "PVar" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),Concat (List [String "x",ShowInt
FieldIndex])])]),App "Var" (List [App "()" (List []),App "UnQual"
(List [App "()" (List []),App "Ident" (List [App "()" (List []),
String "get"])])])])),List [App "Qualifier" (List [App "()" (List
[]),App "App" (List [App "()" (List []),App "Var" (List [App "()"
(List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "return"])])]),App "Paren" (List [App
"()" (List []),Application (Concat (List [List [App "Con" (List [
App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),CtorName])])])],MapField (App
"Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),Concat (List [String "x"
,ShowInt FieldIndex])])])]))]))])])])]])])]),App "Nothing" (List [
])])),List [App "Alt" (List [App "()" (List []),App "PWildCard" (
List [App "()" (List [])]),App "UnGuardedRhs" (List [App "()" (
List []),App "App" (List [App "()" (List []),App "Var" (List [App
"()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),String "error"])])]),App "Lit" (List [
App "()" (List []),App "String" (List [App "()" (List []),Concat (
List [String "Corrupted binary data for ",DataName]),Concat (List
[String "Corrupted binary data for ",DataName])])])])]),App
"Nothing" (List [])])]])])])]])]),App "Just" (List [App "BDecls" (
List [App "()" (List []),List [App "PatBind" (List [App "()" (List
[]),App "PVar" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),String "useTag"])]),App "UnGuardedRhs" (List [App
"()" (List []),App "InfixApp" (List [App "()" (List []),App "App"
(List [App "()" (List []),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "length"])])]),App "List" (List [App "()" (List []
),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"
(List [App "()" (List []),App "Ident" (List [App "()" (List []),
CtorName])]),List []]))])]),App "QVarOp" (List [App "()" (List [])
,App "UnQual" (List [App "()" (List []),App "Symbol" (List [App
"()" (List []),String ">"])])]),App "Lit" (List [App "()" (List []
),App "Int" (List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]
),App "Nothing" (List [])]),App "PatBind" (List [App "()" (List []
),App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),String "getTag"])]),App "UnGuardedRhs" (List [App "()" (
List []),App "If" (List [App "()" (List []),App "Var" (List [App
"()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),String "useTag"])])]),App "Var" (List [
App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),Concat (List [String "getWord",
ShowInt (Int 8)])])])]),App "App" (List [App "()" (List []),App
"Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "return"])])]),
App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (
List []),Int 0,ShowInt (Int 0)])])])])]),App "Nothing" (List [])])
]])])])])]]))]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/BinaryDefer.hs 0000644 0000000 0000000 00000011002 07346545000 016571 0 ustar 00 0000000 0000000 module Data.Derive.BinaryDefer where
{-
import "binarydefer" Data.Binary.Defer
example :: Sample
instance BinaryDefer a => BinaryDefer (Sample a) where
bothDefer = defer [\ ~(o@(First)) -> if null [] then unit (First) < if null [const () x1, const () x2] then unit (Second x1 x2) < if null [const () x1] then unit (Third x1) < BinaryDefer (FailList e a) where
bothDefer = defer [\ ~(o@Zoro) -> unit Zoro < unit Fial << x1
,\ ~(Const x1 x2) -> unit Const << x1 << x2
]
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeBinaryDefer :: Derivation
makeBinaryDefer = derivationDSL "BinaryDefer" dslBinaryDefer
dslBinaryDefer =
List [Instance ["BinaryDefer"] "BinaryDefer" (App "Just" (List [
List [App "InsDecl" (List [App "()" (List []),App "PatBind" (List
[App "()" (List []),App "PVar" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "bothDefer"])]),App
"UnGuardedRhs" (List [App "()" (List []),App "App" (List [App "()"
(List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"defer"])])]),App "List" (List [App "()" (List []),MapCtor (App
"Lambda" (List [App "()" (List []),List [App "PIrrPat" (List [App
"()" (List []),App "PParen" (List [App "()" (List []),App "PAsPat"
(List [App "()" (List []),App "Ident" (List [App "()" (List []),
String "o"]),App "PParen" (List [App "()" (List []),App "PApp" (
List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),CtorName])]),MapField (App
"PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List
[]),Concat (List [String "x",ShowInt FieldIndex])])]))])])])])])],
App "If" (List [App "()" (List []),App "App" (List [App "()" (List
[]),App "Var" (List [App "()" (List []),App "UnQual" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),String "null"
])])]),App "List" (List [App "()" (List []),MapField (Application
(List [App "Var" (List [App "()" (List []),App "UnQual" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),String
"const"])])]),App "Con" (List [App "()" (List []),App "Special" (
List [App "()" (List []),App "UnitCon" (List [App "()" (List [])])
])]),App "Var" (List [App "()" (List []),App "UnQual" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),Concat (List
[String "x",ShowInt FieldIndex])])])])]))])]),App "InfixApp" (List
[App "()" (List []),App "App" (List [App "()" (List []),App "Var"
(List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),String "unit"])])]),App
"Paren" (List [App "()" (List []),Application (Concat (List [List
[App "Con" (List [App "()" (List []),App "UnQual" (List [App "()"
(List []),App "Ident" (List [App "()" (List []),CtorName])])])],
MapField (App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),Concat (
List [String "x",ShowInt FieldIndex])])])]))]))])]),App "QVarOp" (
List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Symbol" (List [App "()" (List []),String "< Bounded (Sample a) where
minBound = head [First, Second (const minBound 1) (const minBound 2), Third (const minBound 1)]
maxBound = head [Third (const maxBound 1), Second (const maxBound 1) (const maxBound 2), First]
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeBounded :: Derivation
makeBounded = derivationDSL "Bounded" dslBounded
dslBounded =
List [Instance ["Bounded"] "Bounded" (App "Just" (List [List [App
"InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"
(List []),App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),String "minBound"])]),App "UnGuardedRhs" (List
[App "()" (List []),App "App" (List [App "()" (List []),App "Var"
(List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),String "head"])])]),App
"List" (List [App "()" (List []),MapCtor (Application (Concat (
List [List [App "Con" (List [App "()" (List []),App "UnQual" (List
[App "()" (List []),App "Ident" (List [App "()" (List []),CtorName
])])])],MapField (App "Paren" (List [App "()" (List []),
Application (List [App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "const"])])]),App "Var" (List [App "()" (List []),
App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),String "minBound"])])]),App "Lit" (List [App "()" (List
[]),App "Int" (List [App "()" (List []),FieldIndex,ShowInt
FieldIndex])])])]))])))])])]),App "Nothing" (List [])])]),App
"InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"
(List []),App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),String "maxBound"])]),App "UnGuardedRhs" (List
[App "()" (List []),App "App" (List [App "()" (List []),App "Var"
(List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),String "head"])])]),App
"List" (List [App "()" (List []),Reverse (MapCtor (Application (
Concat (List [List [App "Con" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),CtorName])])])],MapField (App "Paren" (List [App "()" (
List []),Application (List [App "Var" (List [App "()" (List []),
App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),String "const"])])]),App "Var" (List [App "()" (List [])
,App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),String "maxBound"])])]),App "Lit" (List [App "()" (
List []),App "Int" (List [App "()" (List []),FieldIndex,ShowInt
FieldIndex])])])]))]))))])])]),App "Nothing" (List [])])])]]))]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/Class/ 0000755 0000000 0000000 00000000000 07346545000 015116 5 ustar 00 0000000 0000000 derive-2.6.5/src/Data/Derive/Class/Arities.hs 0000644 0000000 0000000 00000000131 07346545000 017045 0 ustar 00 0000000 0000000
module Data.Derive.Class.Arities where
class Arities a where
arities :: a -> [Int]
derive-2.6.5/src/Data/Derive/Class/Default.hs 0000644 0000000 0000000 00000000114 07346545000 017032 0 ustar 00 0000000 0000000
module Data.Derive.Class.Default where
class Default a where
def :: a
derive-2.6.5/src/Data/Derive/DSL/ 0000755 0000000 0000000 00000000000 07346545000 014473 5 ustar 00 0000000 0000000 derive-2.6.5/src/Data/Derive/DSL/Apply.hs 0000644 0000000 0000000 00000005146 07346545000 016122 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
module Data.Derive.DSL.Apply(apply, applyEnv, env, Env(..)) where
import Data.Derive.DSL.HSE
import Data.Derive.DSL.DSL
import Data.List
import Data.Generics.Uniplate.DataOnly
apply :: DSL -> Input -> Out
apply dsl input = fromOutput $ applyEnv dsl env{envInput=input}
env = Env
(error "Env.envInput: uninitialised")
(error "Env.envCtor: uninitialised")
(error "Env.envField: uninitialised")
(error "Env.envFold: uninitialised")
data Env = Env {envInput :: Input
,envCtor :: Ctor
,envField :: Integer
,envFold :: (Output,Output) }
applyEnv :: DSL -> Env -> Output
applyEnv dsl env@(Env input ctor field fold) = f dsl
where
f (Instance ctx hd body) =
OApp "InstDecl"
[out ()
,out (Nothing :: Maybe (Overlap ()))
,out (IRule () Nothing context insthead :: InstRule ())
,f body]
where
context = Just $ CxTuple ()
[ClassA () (UnQual () $ Ident () c) [TyVar () $ Ident () v]
| let seen = [x | TyVar () (Ident () x) <- universeBi $ concatMap ctorDeclFields $ dataCtors input]
, v <- dataDeclVarsStar input `intersect` seen
, c <- ctx]
ty = TyParen () $ foldl (TyApp ())
(TyCon () $ UnQual () $ Ident () $ dataName input)
(map tyVar $ dataDeclVars input)
insthead = IHApp () (IHCon () $ UnQual () $ Ident () hd) ty
f (Application (f -> OList xs)) =
foldl1 (\a b -> OApp "App" [OApp "()" [],a,b]) xs
f (MapCtor dsl) = OList [applyEnv dsl env{envCtor=c}
| c <- dataCtors input]
f (MapField dsl) = OList [applyEnv dsl env{envField=i}
| i <- [1.. fromIntegral $ ctorArity ctor]]
f DataName = OString $ dataName input
f CtorName = OString $ ctorName ctor
f CtorArity = OInt $ ctorArity ctor
f CtorIndex = OInt $ ctorIndex input ctor
f FieldIndex = OInt $ field
f Head = fst fold
f Tail = snd fold
f (Fold cons (f -> OList xs)) =
foldr1 (\a b -> applyEnv cons env{envFold=(a,b)}) xs
f (List xs) = OList $ map f xs
f (Reverse (f -> OList xs)) = OList $ reverse xs
f (Concat (f -> OList [])) = OList []
f (Concat (f -> OList xs)) = foldr1 g xs
where g (OList x) (OList y) = OList (x++y)
g (OString x) (OString y) = OString (x++y)
f (String x) = OString x
f (Int x) = OInt x
f (ShowInt (f -> OInt x)) = OString $ show x
f (App x (f -> OList ys)) = OApp x ys
derive-2.6.5/src/Data/Derive/DSL/DSL.hs 0000644 0000000 0000000 00000007107 07346545000 015456 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
module Data.Derive.DSL.DSL where
import Data.Derive.DSL.HSE
import Data.List
import Data.Data
import Data.Generics.Uniplate.DataOnly
data DSL = App String DSL{-List-}
| Concat DSL
| Reverse DSL
| String String
| ShowInt DSL
| Int Integer
| List [DSL]
| MapField DSL
| MapCtor DSL
| DataName
| CtorName
| CtorIndex
| CtorArity
| FieldIndex
| Fold DSL DSL
| Head
| Tail
| Instance [String] String DSL{-[InstDecl]-}
| Application DSL{-List-}
deriving (Data,Typeable,Show)
box x = List [x]
nil = List []
append x y = Concat $ List [x,y]
fromOut :: Output -> DSL
fromOut (OApp x y) = App x (List $ map fromOut y)
fromOut (OList x) = List (map fromOut x)
fromOut (OString x) = String x
fromOut x = error $ show ("fromOut",x)
{-
_1 s x1 = App s $ List [x1]
_2 s x1 x2 = App s $ List [x1,x2]
_3 s x1 x2 x3 = App s $ List [x1,x2,x3]
_5 s x1 x2 x3 x4 x5 = App s $ List [x1,x2,x3,x4,x5]
o x = fromOut $ out x
dslEq :: DSL
dslEq = box $ Instance ["Eq"] "Eq" $ box $ _1 "InsDecl" $ _1 "FunBind" $ match `append` dull
where
match = MapCtor $ _5 "Match" (o $ Symbol "==") (List [vars "x",vars "y"]) (o (Nothing :: Maybe Type)) (_1 "UnGuardedRhs" bod) (o $ BDecls [])
vars x = _2 "PApp" (_1 "UnQual" $ _1 "Ident" CtorName) (MapField (_1 "PVar" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)))
bod = Fold (_3 "InfixApp" Head (o $ QVarOp $ UnQual $ Symbol "&&") Tail) $ MapField pair `append` o [Con $ UnQual $ Ident "True"]
pair = _3 "InfixApp" (var "x") (o $ QVarOp $ UnQual $ Symbol "==") (var "y")
var x = _1 "Var" $ _1 "UnQual" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)
dull = o [Match sl (Symbol "==") [PWildCard,PWildCard] Nothing (UnGuardedRhs $ Con $ UnQual $ Ident "False") (BDecls [])]
-}
simplifyDSL :: DSL -> DSL
simplifyDSL = transform f
where
f (Concat (List xs)) = case g xs of
[x] -> x
[] -> List []
xs -> Concat $ List xs
f x = x
g (List x:List y:zs) = g $ List (x++y):zs
g (List []:xs) = g xs
g (String "":xs) = g xs
g (x:xs) = x : g xs
g [] = []
prettyTex :: DSL -> String
prettyTex = f id . transform g
where
bracket x = "(" ++ x ++ ")"
f b (App x (List [])) = x
f b (App x (List xs)) = b $ unwords $ x : map (f bracket) xs
f b (App x y) = b $ x ++ " " ++ f bracket y
f b (Concat x) = b $ "concat " ++ f bracket x
f b (Reverse x) = b $ "reverse " ++ f bracket x
f b (String x) = show x
f b (ShowInt x) = b $ "showInt " ++ f bracket x
f b (Int x) = show x
f b (List []) = "nil"
f b (List x) = b $ "list (" ++ concat (intersperse "," $ map (f id) x) ++ ")"
f b (MapField x) = b $ "mapField " ++ f bracket x
f b (MapCtor x) = b $ "mapCtor " ++ f bracket x
f b DataName = "dataName"
f b CtorName = "ctorName"
f b CtorIndex = "ctorIndex"
f b CtorArity = "ctorArity"
f b FieldIndex = "fieldIndex"
f b (Fold x y) = b $ "fold " ++ f bracket x ++ " " ++ f bracket y
f b Head = "head"
f b Tail = "tail"
f b (Instance x y z) = b $ "instance_ " ++ show x ++ " " ++ show y ++ " " ++ f bracket z
f b (Application x) = b $ "application " ++ f bracket x
g (App x (List [y])) | x `elem` words "Ident UnGuardedRhs UnQual Lit" = y
g x = x
derive-2.6.5/src/Data/Derive/DSL/Derive.hs 0000644 0000000 0000000 00000013250 07346545000 016246 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards #-}
module Data.Derive.DSL.Derive(derive) where
import Control.Arrow
import Data.Derive.DSL.HSE
import Data.Derive.DSL.DSL
import Data.Derive.DSL.Apply
import Data.List
import Data.Char
import Data.Maybe
data Guess = Guess DSL
| GuessFld Int DSL
| GuessCtr Int Bool DSL -- 0 based index, does it mention CtorName
deriving Show
ctrNames = map ctorName $ dataCtors sample
derive :: Out -> [DSL]
derive x = [simplifyDSL y | Guess y <- guess $ toOutput x]
guess :: Output -> [Guess]
guess (OApp "InstDecl" [_,OApp "Nothing" [],rule,decls])
| OApp "IRule" [_, OApp "Nothing" [], ctx, ihead] <- unparen rule
, (name, types) <- unInstHead ihead
, OApp "UnQual" [_, OApp "Ident" [_, OString name]] <- name
, [OApp "TyParen" [_,OApp "TyApp"
[_,OApp "TyCon" [_,OApp "UnQual" [_,OApp "Ident" [_,OString nam]]]
,OApp "TyVar" [_,OApp "Ident" [_,OString var]]]]] <- types
, nam == dataName sample
= [Guess $ Instance (unContext ctx) name y | Guess y <- guess decls]
where
unContext (OApp "Just" [x])
| OApp "CxSingle" [_,x] <- x = unClass x
| OApp "CxTuple" [_,OList xs] <- x = concatMap unClass xs
unContext x = []
unClass (OApp "ClassA" [_,OApp "UnQual" [_,OApp "Ident" [_,OString x]],_]) = [x]
unClass _ = []
unInstHead (OApp "IHCon" [_, name]) = (name, [])
unInstHead (OApp "IHInfix" [_, ty, name]) = (name, [ty])
unInstHead (OApp "IHParen" [_, x]) = unInstHead x
unInstHead (OApp "IHApp" [_, hd, ty]) = second (++[ty]) $ unInstHead hd
unparen (OApp p [_, x]) | "Paren" `isInfixOf` p = unparen x
unparen x = x
guess (OList xs) = guessList xs
guess o@(OApp op xs) = gssFold o ++ gssApp o ++ map (lift (App op)) (guessList xs)
guess (OString x)
| Just i <- findIndex (`isSuffixOf` x) ctrNames = [GuessCtr i True $ String (take (length x - length (ctrNames !! i)) x) `append` CtorName]
| "Sample" `isSuffixOf` x = [Guess $ String (take (length x - 6) x) `append` DataName]
| otherwise =
[lift (\d -> append (String $ init x) (ShowInt d)) g | x /= "", isDigit (last x), g <- guess $ OInt $ read [last x]] ++
[Guess $ String x]
guess (OInt i) =
[GuessFld (fromInteger i) FieldIndex | i `elem` [1,2]] ++
[GuessCtr 1 False CtorIndex | i == 1] ++
[GuessCtr 1 False CtorArity | i == 2] ++
[Guess $ Int i]
guess x = error $ show ("fallthrough",x)
{-
First try and figure out runs to put them in to one possible option
Then try and figure out similarities to give them the same type
-}
guessList :: [Output] -> [Guess]
guessList xs = mapMaybe sames $ map diffs $ sequence $ map guess xs
where
-- Given a list of guesses, try and collapse them into one coherent guess
-- Each input Guess will guess at a List, so compose with Concat
sames :: [Guess] -> Maybe Guess
sames xs = do
let (is,fs) = unzip $ map fromGuess xs
i <- maxim is
return $ toGuess i $ Concat $ List fs
-- Promote each Guess to be a list
diffs :: [Guess] -> [Guess]
diffs (GuessCtr 0 True x0:GuessCtr 1 True x1:GuessCtr 2 True x2:xs)
| f 0 x0 == f 0 x1 && f 2 x2 == f 2 x1 = Guess (MapCtor x1) : diffs xs
where f i x = applyEnv x env{envInput=sample, envCtor=dataCtors sample !! i}
diffs (GuessCtr 2 True x2:GuessCtr 1 True x1:GuessCtr 0 True x0:xs)
| f 0 x0 == f 0 x1 && f 2 x2 == f 2 x1 = Guess (Reverse $ MapCtor x1) : diffs xs
where f i x = applyEnv x env{envInput=sample, envCtor=dataCtors sample !! i}
diffs (GuessFld 1 x1:GuessFld 2 x2:xs)
| f 1 x1 == f 1 x2 = GuessCtr 1 False (MapField x2) : diffs xs
where f i x = applyEnv x env{envInput=sample, envField=i}
diffs (GuessFld 2 x2:GuessFld 1 x1:xs)
| f 1 x1 == f 1 x2 = GuessCtr 1 False (Reverse $ MapField x2) : diffs xs
where f i x = applyEnv x env{envInput=sample, envField=i}
diffs (x:xs) = lift box x : diffs xs
diffs [] = []
gssFold o@(OApp op [pre,x,m,y]) = f True (x : follow True y) ++ f False (y : follow False x)
where
follow dir (OApp op2 [pre2,a,m2,b]) | op == op2 && pre == pre2 && m == m2 = a2 : follow dir b2
where (a2,b2) = if dir then (a,b) else (b,a)
follow dir x = [x]
f dir xs | length xs <= 2 = []
f dir xs | pre:_ <- [d | Guess d <- guess pre] = map (lift $ g pre) $ guess $ OList xs
where g pre = Fold (App op $ List [pre,h,fromOut m,t])
(h,t) = if dir then (Head,Tail) else (Tail,Head)
gssFold _ = []
gssApp (OApp "App" [_,OApp "App" [_,x,y],z]) = map (lift Application) $ guess $ OList $ fromApp x ++ [y,z]
where fromApp (OApp "App" [_,x,y]) = fromApp x ++ [y]
fromApp x = [x]
gssApp _ = []
lift :: (DSL -> DSL) -> Guess -> Guess
lift f x = toGuess a (f b)
where (a,b) = fromGuess x
type GuessState = Maybe (Either Int (Int,Bool))
fromGuess :: Guess -> (GuessState, DSL)
fromGuess (Guess x) = (Nothing, x)
fromGuess (GuessFld i x) = (Just (Left i), x)
fromGuess (GuessCtr i b x) = (Just (Right (i,b)), x)
toGuess :: GuessState -> DSL -> Guess
toGuess Nothing = Guess
toGuess (Just (Left i)) = GuessFld i
toGuess (Just (Right (i,b))) = GuessCtr i b
-- return the maximum element, if one exists
maxim :: [GuessState] -> Maybe GuessState
maxim [] = Just Nothing
maxim [x] = Just x
maxim (Nothing:xs) = maxim xs
maxim (x:Nothing:xs) = maxim $ x:xs
maxim (x1:x2:xs) | x1 == x2 = maxim $ x1:xs
maxim (Just (Right (i1,b1)):Just (Right (i2,b2)):xs) | i1 == i2 = maxim $ Just (Right (i1,max b1 b2)) : xs
maxim _ = Nothing
derive-2.6.5/src/Data/Derive/DSL/HSE.hs 0000644 0000000 0000000 00000006545 07346545000 015460 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
module Data.Derive.DSL.HSE(module Data.Derive.DSL.HSE, module Language.Haskell) where
import Language.Haskell hiding (List, App, String, Int)
import Data.Data
import Data.Generics.Uniplate.DataOnly
import Data.Maybe
import Data.List
import Data.Function
import Control.Monad.Trans.State
---------------------------------------------------------------------
-- EXAMPLES
{-
-- data List a = Nil | Cons a (List a)
list :: Input
list = Input "List" 1 [Ctor "Nil" 0 0, Ctor "Cons" 1 2]
-}
-- data Sample a = First | Second a a | Third a
sample :: Input
sample = DataDecl () (DataType ()) Nothing (DHApp () (DHead () $ name "Sample") (tyVarBind "a")) ctrs []
where
ctrs = [ctr "First" 0, ctr "Second" 2, ctr "Third" 1]
ctr s i = QualConDecl () Nothing Nothing $ ConDecl () (name s) $ replicate i $ tyVar "a"
---------------------------------------------------------------------
-- UTILITIES
outEq :: Out -> Out -> Bool
outEq = (==) `on` transformBi (const sl)
---------------------------------------------------------------------
showOut x = unlines $ map prettyPrint x
type Input = DataDecl
type Ctor = CtorDecl
dataName = dataDeclName
dataVars = length . dataDeclVars
dataCtors = dataDeclCtors
ctorName = ctorDeclName
ctorArity = fromIntegral . ctorDeclArity
ctorIndex :: Input -> Ctor -> Integer
ctorIndex dat ctor = fromIntegral $ fromMaybe (error "fromJust: ctorIndex") $ findIndex (== ctor) $ dataCtors dat
toInput :: DataDecl -> Input
toInput x = x
type Out = [Decl ()]
data Output = OString String
| OInt Integer
| OApp String [Output]
| OList [Output]
| OIgnore
| OCustom String
deriving (Eq,Show,Data,Typeable)
toOutput :: Data a => a -> Output
toOutput x
| t == typeOf "" = OString $ coerce x
| c == "[]" = OList $ fList x
| t == typeOf sl = OIgnore
| t == typeOf (1 :: Integer) = OInt $ coerce x
| otherwise = OApp (showConstr $ toConstr x) (filter (/= OIgnore) $ gmapQ toOutput x)
where
t = typeOf x
c = show $ fst $ splitTyConApp t
fList :: Data a => a -> [Output]
fList = gmapQl (++) [] $ \x -> if typeOf x == t then fList x else [toOutput x]
fromOutput :: Data a => Output -> a
fromOutput (OList xs) = res
where res = f xs
f [] = fromConstr $ readCon dat "[]"
f (x:xs) = fromConstrB (g x (f xs `asTypeOf` res)) $ readCon dat "(:)"
dat = dataTypeOf res
g :: (Data a, Data b) => Output -> a -> b
g x xs = r2 where r2 = if typeOf r2 == typeOf xs then coerce xs else fromOutput x
fromOutput (OApp str args) = res
where dat = dataTypeOf res
res = evalState (fromConstrM f $ readCon dat str) args
f :: Data a => State [Output] a
f = res where res = if typeOf (fromState res) == typeOf sl then return $ coerce sl else
do l <- get
case l of
x:xs -> do put xs; return $ fromOutput x
[] -> error "fromOutput: null"
fromOutput (OString x) = coerce x
fromOutput (OInt x) = coerce x
coerce x = fromMaybe (error "Error in coerce") $ cast x
readCon dat x = fromMaybe (error $ "Error in readCon, " ++ x) $ readConstr dat x
out x = toOutput x
fromState :: State a x -> x
fromState = undefined
derive-2.6.5/src/Data/Derive/DSL/SYB.hs 0000644 0000000 0000000 00000007052 07346545000 015470 0 ustar 00 0000000 0000000 {-# LANGUAGE RelaxedPolyRec, RankNTypes, ScopedTypeVariables #-}
{- OPTIONS_GHC -fglasgow-exts -}
module Data.Derive.DSL.SYB(dslSYB) where
import Data.Derive.DSL.HSE
import qualified Language.Haskell.Exts as H
import Data.Derive.DSL.DSL
import Control.Monad.Trans.State
import Control.Monad
import Data.Generics
import Data.Maybe
dslSYB :: DSL -> Maybe Out
dslSYB = syb
syb :: Data a => DSL -> Maybe a
syb = dsimple & dlistAny & dapp -- & (\x -> error $ "Failed to generate for SYB, " ++ show x)
lift :: (Data a, Data b) => (DSL -> Maybe b) -> (DSL -> Maybe a)
lift f = maybe Nothing id . cast . f
(&) a b x = a x `mplus` b x
dlistAny :: forall a . Data a => DSL -> Maybe a
dlistAny x | isNothing con = Nothing
| otherwise = res
where
con = readConstr dat "(:)"
val = fromConstr (fromJust con) :: a
dat = dataTypeOf (undefined :: a)
res = gmapQi 0 f val
f :: Data d => d -> Maybe a
f y = fromJust $ cast $ dlist x `asTypeOf` Just [y]
dlist :: Data a => DSL -> Maybe [a]
dlist x = do
List xs <- return x
mapM syb xs
dapp :: forall a . Data a => DSL -> Maybe a
dapp x = do
App name (List args) <- return x
let dat = dataTypeOf (undefined :: a)
(res,s) = runState (fromConstrM f $ readCon dat name) (True,args)
if fst s then Just res else Nothing
where
f :: forall b . Data b => State (Bool,[DSL]) b
f = if typeOf (undefined :: b) == typeOf sl then return $ coerce sl
else do
(b,l) <- get
case l of
x:xs ->
case syb x of
Nothing -> do put (False,xs) ; return undefined
Just y -> do put (b,xs) ; return y
[] ->
error "dapp: null"
dsimple :: Data a => DSL -> Maybe a
dsimple = lift dinstance & lift dstring & lift dapplication & lift dmapctor & lift dsingle
dinstance :: DSL -> Maybe (Decl ())
dinstance x = do
Instance _ name bod <- return x
bod <- syb bod
let ctx = ClassA () (UnQual () $ Ident () "Data") [TyVar () $ Ident () "d_type"]
let rule = IRule () Nothing (Just (CxSingle () ctx))
(IHApp () (IHCon () (UnQual () $ Ident () name)) (TyVar () $ Ident () "d_type"))
return $ InstDecl () Nothing rule bod
dstring :: DSL -> Maybe String
dstring x = do
String x <- return x
return x
dmapctor :: DSL -> Maybe (Exp ())
dmapctor x = do
App "List" (List [_, MapCtor x]) <- return x
x <- syb x
return $ ListComp () x [QualStmt () $ Generator () (PVar () $ Ident () "d_ctor")
(H.App () (v "d_dataCtors") (Paren () $ ExpTypeSig () (v "undefined") (TyVar () $ Ident () "d_type")))]
dsingle :: DSL -> Maybe (Exp ())
dsingle (App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []),CtorArity,ShowInt CtorArity])])) = Just $ Paren () $ H.App () (v "d_ctorArity") (v "d_ctor")
dsingle (App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []),CtorIndex,ShowInt CtorIndex])])) = Just $ Paren () $ H.App () (v "d_ctorIndex") (v "d_ctor")
dsingle (App "RecConstr" (List [_, App "UnQual" (List [_, App "Ident" (List [_, CtorName])]),List []])) = Just $ Paren () $
ExpTypeSig () (H.App () (v "d_ctorValue") (v "d_ctor")) (TyVar () $ Ident () "d_type")
dsingle _ = Nothing
dapplication :: DSL -> Maybe (Exp ())
dapplication x = do
Application (List xs) <- return x
syb $ f xs
where
f (x:y:z) = f (App "App" (List [App "()" $ List [],x,y]) : z)
f [x] = x
v = Var () . UnQual () . Ident ()
derive-2.6.5/src/Data/Derive/DataAbstract.hs 0000644 0000000 0000000 00000007705 07346545000 016753 0 ustar 00 0000000 0000000 {-|
For deriving Data on abstract data types.
-}
module Data.Derive.DataAbstract(makeDataAbstract) where
{-
import Data.Data(Data(..))
example :: Custom
instance Typeable a => Data (Sample a) where
gfoldl k r x = r x
gunfold = error "Data.gunfold not implemented on abstract data type: Sample"
toConstr = error "Data.gunfold not implemented on abstract data type: Sample"
dataTypeOf = error "Data.gunfold not implemented on abstract data type: Sample"
-}
import Data.Derive.DSL.HSE
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeDataAbstract :: Derivation
makeDataAbstract = derivationCustomDSL "DataAbstract" custom $
List [Instance ["Typeable"] "Data" (App "Just" (List [List [App
"InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"
(List []),List [App "Match" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),String "gfoldl"]),List [App "PVar" (List
[App "()" (List []),App "Ident" (List [App "()" (List []),String
"k"])]),App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),String "r"])]),App "PVar" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "x"])])],App
"UnGuardedRhs" (List [App "()" (List []),App "App" (List [App "()"
(List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"r"])])]),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"x"])])])])]),App "Nothing" (List [])])]])]),App "InsDecl" (List [
App "()" (List []),App "PatBind" (List [App "()" (List []),App
"PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List
[]),String "gunfold"])]),App "UnGuardedRhs" (List [App "()" (List
[]),App "App" (List [App "()" (List []),App "Var" (List [App "()"
(List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "error"])])]),App "Lit" (List [App "()"
(List []),App "String" (List [App "()" (List []),Concat (List [
String "Data.gunfold not implemented on abstract data type: ",
DataName]),Concat (List [String
"Data.gunfold not implemented on abstract data type: ",DataName])]
)])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App "()"
(List []),App "PatBind" (List [App "()" (List []),App "PVar" (List
[App "()" (List []),App "Ident" (List [App "()" (List []),String
"toConstr"])]),App "UnGuardedRhs" (List [App "()" (List []),App
"App" (List [App "()" (List []),App "Var" (List [App "()" (List []
),App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),String "error"])])]),App "Lit" (List [App "()" (
List []),App "String" (List [App "()" (List []),Concat (List [
String "Data.gunfold not implemented on abstract data type: ",
DataName]),Concat (List [String
"Data.gunfold not implemented on abstract data type: ",DataName])]
)])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App "()"
(List []),App "PatBind" (List [App "()" (List []),App "PVar" (List
[App "()" (List []),App "Ident" (List [App "()" (List []),String
"dataTypeOf"])]),App "UnGuardedRhs" (List [App "()" (List []),App
"App" (List [App "()" (List []),App "Var" (List [App "()" (List []
),App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),String "error"])])]),App "Lit" (List [App "()" (
List []),App "String" (List [App "()" (List []),Concat (List [
String "Data.gunfold not implemented on abstract data type: ",
DataName]),Concat (List [String
"Data.gunfold not implemented on abstract data type: ",DataName])]
)])])]),App "Nothing" (List [])])])]]))]
-- GENERATED STOP
custom = customContext context
context :: FullDataDecl -> Context () -> Context ()
context d _ = CxTuple () [ClassA () (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
derive-2.6.5/src/Data/Derive/Default.hs 0000644 0000000 0000000 00000003154 07346545000 015774 0 ustar 00 0000000 0000000 module Data.Derive.Default where
{-
import "derive" Data.Derive.Class.Default
example :: Sample
instance Default a => Default (Sample a) where
def = head [First, Second (const def 1) (const def 2), Third (const def 1)]
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeDefault :: Derivation
makeDefault = derivationDSL "Default" dslDefault
dslDefault =
List [Instance ["Default"] "Default" (App "Just" (List [List [App
"InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"
(List []),App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),String "def"])]),App "UnGuardedRhs" (List [App
"()" (List []),App "App" (List [App "()" (List []),App "Var" (List
[App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "head"])])]),App "List" (
List [App "()" (List []),MapCtor (Application (Concat (List [List
[App "Con" (List [App "()" (List []),App "UnQual" (List [App "()"
(List []),App "Ident" (List [App "()" (List []),CtorName])])])],
MapField (App "Paren" (List [App "()" (List []),Application (List
[App "Var" (List [App "()" (List []),App "UnQual" (List [App "()"
(List []),App "Ident" (List [App "()" (List []),String "const"])])
]),App "Var" (List [App "()" (List []),App "UnQual" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),String "def"]
)])]),App "Lit" (List [App "()" (List []),App "Int" (List [App
"()" (List []),FieldIndex,ShowInt FieldIndex])])])]))])))])])]),
App "Nothing" (List [])])])]]))]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/EnumCyclic.hs 0000644 0000000 0000000 00000021330 07346545000 016437 0 ustar 00 0000000 0000000 module Data.Derive.EnumCyclic where
{-
import Prelude(Enum)
example :: Sample
instance Enum (Sample a) where
toEnum 0 = First{}
toEnum 1 = Second{}
toEnum 2 = Third{}
toEnum n = error $ "toEnum " ++ show n ++ ", not defined for Sample"
fromEnum (First{}) = 0
fromEnum (Second{}) = 1
fromEnum (Third{}) = 2
succ a = if b == length [First{},Second{},Third{}] then toEnum 0 else toEnum (b+1)
where b = fromEnum a
pred a = if b == 0 then toEnum (length [First{},Second{},Third{}]) else toEnum (b-1)
where b = fromEnum a
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeEnumCyclic :: Derivation
makeEnumCyclic = derivationDSL "EnumCyclic" dslEnumCyclic
dslEnumCyclic =
List [Instance [] "Enum" (App "Just" (List [List [App "InsDecl" (
List [App "()" (List []),App "FunBind" (List [App "()" (List []),
Concat (List [MapCtor (App "Match" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "toEnum"]),List [App
"PLit" (List [App "()" (List []),App "Signless" (List [App "()" (
List [])]),App "Int" (List [App "()" (List []),CtorIndex,ShowInt
CtorIndex])])],App "UnGuardedRhs" (List [App "()" (List []),App
"RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"
(List []),App "Ident" (List [App "()" (List []),CtorName])]),List
[]])]),App "Nothing" (List [])])),List [App "Match" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),String
"toEnum"]),List [App "PVar" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),String "n"])])],App "UnGuardedRhs" (List
[App "()" (List []),App "InfixApp" (List [App "()" (List []),App
"Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "error"])])]),App
"QVarOp" (List [App "()" (List []),App "UnQual" (List [App "()" (
List []),App "Symbol" (List [App "()" (List []),String "$"])])]),
Fold (App "InfixApp" (List [App "()" (List []),Head,App "QVarOp" (
List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Symbol" (List [App "()" (List []),String "++"])])]),Tail])) (
List [App "Lit" (List [App "()" (List []),App "String" (List [App
"()" (List []),String "toEnum ",String "toEnum "])]),App "App" (
List [App "()" (List []),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "show"])])]),App "Var" (List [App "()" (List []),
App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),String "n"])])])]),App "Lit" (List [App "()" (List []),
App "String" (List [App "()" (List []),Concat (List [String
", not defined for ",DataName]),Concat (List [String
", not defined for ",DataName])])])])])]),App "Nothing" (List [])]
)]])])]),App "InsDecl" (List [App "()" (List []),App "FunBind" (
List [App "()" (List []),MapCtor (App "Match" (List [App "()" (
List []),App "Ident" (List [App "()" (List []),String "fromEnum"])
,List [App "PParen" (List [App "()" (List []),App "PRec" (List [
App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),CtorName])]),List []])])],App
"UnGuardedRhs" (List [App "()" (List []),App "Lit" (List [App "()"
(List []),App "Int" (List [App "()" (List []),CtorIndex,ShowInt
CtorIndex])])]),App "Nothing" (List [])]))])]),App "InsDecl" (List
[App "()" (List []),App "FunBind" (List [App "()" (List []),List [
App "Match" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),String "succ"]),List [App "PVar" (List [App "()" (List [
]),App "Ident" (List [App "()" (List []),String "a"])])],App
"UnGuardedRhs" (List [App "()" (List []),App "If" (List [App "()"
(List []),App "InfixApp" (List [App "()" (List []),App "Var" (List
[App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "b"])])]),App "QVarOp" (
List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Symbol" (List [App "()" (List []),String "=="])])]),App "App"
(List [App "()" (List []),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "length"])])]),App "List" (List [App "()" (List []
),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"
(List [App "()" (List []),App "Ident" (List [App "()" (List []),
CtorName])]),List []]))])])]),App "App" (List [App "()" (List []),
App "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (
List []),App "Ident" (List [App "()" (List []),String "toEnum"])])
]),App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (
List []),Int 0,ShowInt (Int 0)])])]),App "App" (List [App "()" (
List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"toEnum"])])]),App "Paren" (List [App "()" (List []),App
"InfixApp" (List [App "()" (List []),App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "b"])])]),App "QVarOp" (List [App "()"
(List []),App "UnQual" (List [App "()" (List []),App "Symbol" (
List [App "()" (List []),String "+"])])]),App "Lit" (List [App
"()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (
Int 1)])])])])])])]),App "Just" (List [App "BDecls" (List [App
"()" (List []),List [App "PatBind" (List [App "()" (List []),App
"PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List
[]),String "b"])]),App "UnGuardedRhs" (List [App "()" (List []),
App "App" (List [App "()" (List []),App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "fromEnum"])])]),App "Var" (List [App
"()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),String "a"])])])])]),App "Nothing" (List
[])])]])])])]])]),App "InsDecl" (List [App "()" (List []),App
"FunBind" (List [App "()" (List []),List [App "Match" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),String "pred"
]),List [App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),String "a"])])],App "UnGuardedRhs" (List [App
"()" (List []),App "If" (List [App "()" (List []),App "InfixApp" (
List [App "()" (List []),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "b"])])]),App "QVarOp" (List [App "()" (List []),
App "UnQual" (List [App "()" (List []),App "Symbol" (List [App
"()" (List []),String "=="])])]),App "Lit" (List [App "()" (List [
]),App "Int" (List [App "()" (List []),Int 0,ShowInt (Int 0)])])])
,App "App" (List [App "()" (List []),App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "toEnum"])])]),App "Paren" (List [App
"()" (List []),App "App" (List [App "()" (List []),App "Var" (List
[App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "length"])])]),App "List"
(List [App "()" (List []),MapCtor (App "RecConstr" (List [App "()"
(List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),CtorName])]),List []]))])])])]),App "App" (
List [App "()" (List []),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "toEnum"])])]),App "Paren" (List [App "()" (List [
]),App "InfixApp" (List [App "()" (List []),App "Var" (List [App
"()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),String "b"])])]),App "QVarOp" (List [App
"()" (List []),App "UnQual" (List [App "()" (List []),App "Symbol"
(List [App "()" (List []),String "-"])])]),App "Lit" (List [App
"()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (
Int 1)])])])])])])]),App "Just" (List [App "BDecls" (List [App
"()" (List []),List [App "PatBind" (List [App "()" (List []),App
"PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List
[]),String "b"])]),App "UnGuardedRhs" (List [App "()" (List []),
App "App" (List [App "()" (List []),App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "fromEnum"])])]),App "Var" (List [App
"()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),String "a"])])])])]),App "Nothing" (List
[])])]])])])]])])]]))]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/Fold.hs 0000644 0000000 0000000 00000004234 07346545000 015274 0 ustar 00 0000000 0000000 -- Contributed by Tim Newsham
{-|
A pseudo derivation. Derive a (non-recursive) fold function for
the type which takes one function per alternative constructor. Each
function takes the same arguments as the constructor and returns
a value. When applied to a value the fold function applies the
function for the matching constructor to the constructor fields.
This provides a first-class alternative to pattern matching to
deconstruct the data type.
-}
module Data.Derive.Fold(makeFold) where
{-
test :: Computer
foldComputer :: (Double -> Int -> a) -> (Int -> a) -> Computer -> a
foldComputer f _ (Laptop x1 x2) = f x1 x2
foldComputer _ f (Desktop x1) = f x1
test :: Assoced
foldAssoced :: (typ -> String -> a) -> Assoced typ -> a
foldAssoced f (Assoced x1 x2) = f x1 x2
test :: Either
foldEither :: (a -> c) -> (b -> c) -> Either a b -> c
foldEither f _ (Left x1) = f x1
foldEither _ f (Right x1) = f x1
test :: Bool
foldBool :: a -> a -> Bool -> a
foldBool f _ False = f
foldBool _ f True = f
-}
import Language.Haskell
import Data.Derive.Internal.Derivation
import Data.List
import Data.Generics.Uniplate.DataOnly
makeFold :: Derivation
makeFold = derivationCustom "Fold" $ \(_,d) -> Right $ simplify $ mkFold d
mkFold :: DataDecl -> [Decl ()]
mkFold d | isIdent $ dataDeclName d = [TypeSig () [name n] (foldType d), FunBind () $ zipWith f [0..] $ dataDeclCtors d]
| otherwise = []
where
n = "fold" ++ title (dataDeclName d)
f i c = Match () (name n) pat (UnGuardedRhs () bod) Nothing
where pat = replicate i (PWildCard ()) ++ [pVar "f"] ++ replicate (length (dataDeclCtors d) - i - 1) (PWildCard ()) ++
[PParen () $ PApp () (qname $ ctorDeclName c) (map pVar vars)]
bod = apps (var "f") (map var vars)
vars = ['x' : show i | i <- [1..length (ctorDeclFields c)]]
foldType :: DataDecl -> Type ()
foldType d = tyFun $ map f (dataDeclCtors d) ++ [dt, v]
where
dt = dataDeclType d
v = head $ map (tyVar . return) ['a'..] \\ universe dt
f c = TyParen () $ tyFun $ map snd (ctorDeclFields c) ++ [v]
derive-2.6.5/src/Data/Derive/From.hs 0000644 0000000 0000000 00000004042 07346545000 015310 0 ustar 00 0000000 0000000 {-|
A pseudo derivation. For each constructor in the data type,
deriving @From@ generates @from@/CtorName/ which extracts the
components if given the appropriate constructor, and crashes
otherwise. Unlike the DrIFT @\"From\"@ derivation, our version
works for all constructors - zero-arity constructors always return
@()@, arity-one constructors return the contained value, and all
others return a tuple with all the components.
-}
module Data.Derive.From(makeFrom) where
{-
test :: Sample
fromFirst :: Sample a -> ()
fromFirst First = ()
fromFirst _ = error "fromFirst failed, not a First"
fromSecond :: Sample a -> (a, a)
fromSecond (Second x1 x2) = (x1,x2)
fromSecond _ = error "fromSecond failed, not a Second"
fromThird :: Sample a -> a
fromThird (Third x1) = x1
fromThird _ = error "fromThird failed, not a Third"
-}
import Language.Haskell
import Data.Derive.Internal.Derivation
makeFrom :: Derivation
makeFrom = derivationCustom "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d
makeFromCtor :: DataDecl -> CtorDecl -> [Decl ()]
makeFromCtor d c | isIdent n = [TypeSig () [name from] typ, FunBind () $ match : [defMatch | length (dataDeclCtors d) > 1]]
| otherwise = []
where
n = ctorDeclName c
from = "from" ++ n
typ = TyFun () (dataDeclType d)
(tyTuple $ map snd $ ctorDeclFields c)
match = Match () (name from) [pat] (UnGuardedRhs () rhs) Nothing
pat = (length vars == 0 ? id $ PParen ()) $ PApp () (qname n) (map pVar vars)
vars = take (length $ ctorDeclFields c) $ map ((:) 'x' . show) [1..]
rhs = valTuple $ map var vars
defMatch = Match () (name from) [PWildCard ()] (UnGuardedRhs () err) Nothing
err = App () (var "error") $ Lit () $ let s = from ++ " failed, not a " ++ n in String () s (show s)
tyTuple [] = TyCon () $ Special () $ UnitCon ()
tyTuple [x] = x
tyTuple xs = TyTuple () Boxed xs
valTuple [] = Con () $ Special () $ UnitCon ()
valTuple [x] = x
valTuple xs = Tuple () Boxed xs
derive-2.6.5/src/Data/Derive/Has.hs 0000644 0000000 0000000 00000002302 07346545000 015115 0 ustar 00 0000000 0000000 {-|
Has is a pseudo derivation. For each field of any constructor of
the data type, Has generates @has@/FieldName/ which returns 'True'
if given the the given field is a member of the constructor of the
passed object, and 'False' otherwise.
-}
module Data.Derive.Has(makeHas) where
{-
test :: Computer
hasSpeed :: Computer -> Bool
hasSpeed _ = True
hasWeight :: Computer -> Bool
hasWeight Laptop{} = True
hasWeight _ = False
test :: Sample
-}
import Language.Haskell
import Data.Derive.Internal.Derivation
import Data.List
makeHas :: Derivation
makeHas = derivationCustom "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d
makeHasField :: DataDecl -> String -> [Decl ()]
makeHasField d field = if isIdent field then [TypeSig () [name has] typ, binds has ms] else []
where
has = "has" ++ title field
typ = TyFun () (dataDeclType d) (tyCon "Bool")
(yes,no) = partition (elem field . map fst . ctorDeclFields) $ dataDeclCtors d
match pat val = ([pat], con val)
ms | null no = [match (PWildCard ()) "True"]
| otherwise = [match (PRec () (qname $ ctorDeclName c) []) "True" | c <- yes] ++ [match (PWildCard ()) "False"]
derive-2.6.5/src/Data/Derive/Instance/ 0000755 0000000 0000000 00000000000 07346545000 015615 5 ustar 00 0000000 0000000 derive-2.6.5/src/Data/Derive/Instance/Arities.hs 0000644 0000000 0000000 00000000651 07346545000 017553 0 ustar 00 0000000 0000000 -- GENERATED START
{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}
module Data.Derive.Instance.Arities where
import Data.Derive.Class.Arities
import Data.Derive.Internal.Instance
instance Data d_type => Arities d_type where
arities _
= [const (d_ctorArity d_ctor) (d_ctorValue d_ctor :: d_type) |
d_ctor <- d_dataCtors (undefined :: d_type)]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/Internal/ 0000755 0000000 0000000 00000000000 07346545000 015625 5 ustar 00 0000000 0000000 derive-2.6.5/src/Data/Derive/Internal/Derivation.hs 0000644 0000000 0000000 00000003101 07346545000 020260 0 ustar 00 0000000 0000000
module Data.Derive.Internal.Derivation(
Derivation(..),
derivationParams, derivationCustom, derivationDSL, derivationCustomDSL,
customSplice, customContext
) where
import Data.DeriveDSL
import Data.Derive.DSL.HSE
import Data.Generics.Uniplate.DataOnly
data Derivation = Derivation
{derivationName :: String
,derivationOp :: Type () -> (String -> Decl ()) -> FullDataDecl -> Either String [Decl ()]
}
derivationParams :: String -> ([Type ()] -> (String -> Decl ()) -> FullDataDecl -> Either String [Decl ()]) -> Derivation
derivationParams name op = Derivation name $ \ty grab decs -> op (snd $ fromTyApps $ fromTyParen ty) grab decs
derivationCustom :: String -> (FullDataDecl -> Either String [Decl ()]) -> Derivation
derivationCustom name op = derivationParams name $ \ty grab decs -> op decs
derivationDSL :: String -> DSL -> Derivation
derivationDSL name dsl = derivationCustomDSL name (const id) dsl
derivationCustomDSL :: String -> (FullDataDecl -> [Decl ()] -> [Decl ()]) -> DSL -> Derivation
derivationCustomDSL name custom dsl = derivationCustom name $
\d -> case applyDSL dsl $ snd d of
Left x -> Left x
Right x -> Right $ simplify $ custom d x
customSplice :: (FullDataDecl -> Exp () -> Exp ()) -> (FullDataDecl -> [Decl ()] -> [Decl ()])
customSplice custom d = transformBi f
where
f (SpliceExp () (ParenSplice () x)) = custom d x
f x = x
customContext :: (FullDataDecl -> Context () -> Context ()) -> (FullDataDecl -> [Decl ()] -> [Decl ()])
customContext custom ds = transformBi (custom ds)
derive-2.6.5/src/Data/Derive/Internal/Instance.hs 0000644 0000000 0000000 00000001426 07346545000 017730 0 ustar 00 0000000 0000000 {-# LANGUAGE ExistentialQuantification #-}
module Data.Derive.Internal.Instance(
Data, d_ctorArity, d_ctorValue, d_dataCtors
) where
import Data.Data
import Control.Monad
import Control.Monad.Trans.State
data Ctor = Ctor
{ctorType :: Box
,ctorRep :: Constr}
data Box = forall a . Data a => Box a
d_ctorArity :: Ctor -> Int
d_ctorArity Ctor{ctorType=Box t, ctorRep=rep} = flip execState 0 $
liftM (`asTypeOf` t) $
fromConstrM (modify (+1) >> return undefined) rep
d_ctorValue :: Data a => Ctor -> a
d_ctorValue = error "TODO: d_ctorValue"
d_dataCtors :: Data a => a -> [Ctor]
d_dataCtors x
| not $ isAlgType t = error "d_dataCtors only works on algebraic data types"
| otherwise = map (Ctor $ Box x) $ dataTypeConstrs t
where t = dataTypeOf x
derive-2.6.5/src/Data/Derive/Internal/Traversal.hs 0000644 0000000 0000000 00000024230 07346545000 020125 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-
This module is not written/maintained by the usual Data.Derive author.
MAINTAINER: Twan van Laarhoven
EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"
Please send all patches to this module to Neil (ndmitchell -at- gmail),
and CC Twan.
-}
-- NOTE: Cannot be guessed as it relies on type information
-- | Derives 'Functor' and similair classes, as discussed on the Haskell-prime mailing list:
-- .
module Data.Derive.Internal.Traversal(
TraveralType(..), defaultTraversalType,
traversalDerivation1,
traversalInstance, traversalInstance1,
deriveTraversal
) where
import Language.Haskell
import Data.Derive.Internal.Derivation
import Data.List
import qualified Data.Set as S
import Control.Monad.Trans.Writer
import Control.Applicative
import Data.Generics.Uniplate.DataOnly
import Data.Maybe
import Prelude
---------------------------------------------------------------------------------
-- Information datatype, public interface
-- | An expression representing a traversal of a subpart of the data
type Trav = Exp ()
-- | What kind of traversal are we deriving?
data TraveralType = TraveralType
{ traversalArg :: Int -- ^ On what position are we traversing?
, traversalCo :: Bool -- ^ covariant?
, traversalName :: QName () -- ^ name of the traversal function
, traversalId :: Trav -- ^ Identity traversal
, traversalDirect :: Trav -- ^ Traversal of 'a'
, traversalFunc :: QName () -> Trav -> Trav -- ^ Apply the sub-traversal function
, traversalPlus :: Trav -> Trav -> Trav -- ^ Apply two non-identity traversals in sequence
, traverseArrow :: Maybe (Trav -> Trav -> Trav) -- ^ Traverse a function type
, traverseTuple :: [Exp ()] -> Exp () -- ^ Construct a tuple from applied traversals
, traverseCtor :: String -> [Exp ()] -> Exp () -- ^ Construct a data type from applied traversals
, traverseFunc :: Pat () -> Exp () -> Match () -- ^ Construct a clause of the traversal function
}
defaultTraversalType = TraveralType
{ traversalArg = 1
, traversalCo = False
, traversalName = undefined -- prevent warnings
, traversalId = var "id"
, traversalDirect = var "_f"
, traversalFunc = \x y -> appP (Var () x) y
, traversalPlus = \x y -> apps (Con () $ Special () (Cons ())) [paren x, paren y]
, traverseArrow = Nothing
, traverseTuple = Tuple () Boxed
, traverseCtor = \x y -> apps (con x) (map paren y)
, traverseFunc = undefined
}
data RequiredInstance = RequiredInstance
{ _requiredDataArg :: String -- ^ What argument of the current data type?
, _requiredPosition :: Int -- ^ What argument position of that type?
}
deriving (Eq, Ord)
-- | Monad that collects required instances
type WithInstances a = Writer (S.Set RequiredInstance) a
vars f c n = [f $ c : show i | i <- [1..n]]
---------------------------------------------------------------------------------
-- Deriving traversals
-- | Derivation for a Traversable like class with just 1 method
traversalDerivation1 :: TraveralType -> String -> Derivation
traversalDerivation1 tt nm = derivationCustom (className $ traversalArg tt) (traversalInstance1 tt nm)
where className n = nm ++ (if n > 1 then show n else "")
-- | Instance for a Traversable like class with just 1 method
traversalInstance1 :: TraveralType -> String -> FullDataDecl -> Either String [Decl ()]
traversalInstance1 tt nm (_,dat)
| isNothing (traverseArrow tt) && any isTyFun (universeBi dat) = Left $ "Can't derive " ++ prettyPrint (traversalName tt) ++ " for types with arrow"
| dataDeclArity dat == 0 = Left "Cannot derive class for data type arity == 0"
| otherwise = Right $ traversalInstance tt nm dat [deriveTraversal tt dat]
-- InstDecl SrcLoc (Maybe Overlap) [TyVarBind] Context QName [Type] [InstDecl]
-- InstDecl l (Maybe (Overlap l)) (InstRule l) (Maybe [InstDecl l])
-- | Instance for a Traversable like class
traversalInstance :: TraveralType -> String -> DataDecl -> [WithInstances (Decl ())] -> [Decl ()]
traversalInstance tt nameBase dat bodyM = -- [simplify $ InstDecl () Nothing [] ctx nam args (map InsDecl body)]
[ simplify $ InstDecl () Nothing instRule (Just $ map (InsDecl ()) body) ]
where
instRule = IRule () Nothing (Just ctx) instHead
instHead = foldr (flip (IHApp ())) (IHCon () nam) args
(body, required) = runWriter (sequence bodyM)
ctx = CxTuple ()
[ ClassA () (qname $ className p) (tyVar n : vars tyVar 's' (p - 1))
| RequiredInstance n p <- S.toList required
]
vrs = vars tyVar 't' (dataDeclArity dat)
(vrsBefore,_:vrsAfter) = splitAt (length vrs - traversalArg tt) vrs
className n = nameBase ++ (if n > 1 then show n else "")
nam = qname (className (traversalArg tt))
args = TyParen () (tyApps (tyCon $ dataDeclName dat) vrsBefore) : vrsAfter
-- Match SrcLoc Name [Pat] (Maybe Type) Rhs (Maybe Binds)
-- Match l (Name l) [Pat l] (Rhs l) (Maybe (Binds l))
-- | Derive a 'traverse' like function
deriveTraversal :: TraveralType -> DataDecl -> WithInstances (Decl ())
deriveTraversal tt dat = fun
where
fun = (\xs -> FunBind () [Match () nam a b c | Match () _ a b c <- xs]) <$> body
args = argPositions dat
nam = unqual $ traversalNameN tt $ traversalArg tt
body = mapM (deriveTraversalCtor tt args) (dataDeclCtors dat)
unqual (Qual () _ x) = x
unqual (UnQual () x) = x
-- | Derive a clause of a 'traverse' like function for a constructor
deriveTraversalCtor :: TraveralType -> ArgPositions -> CtorDecl -> WithInstances (Match ())
deriveTraversalCtor tt ap ctor = do
let nam = ctorDeclName ctor
arity = ctorDeclArity ctor
tTypes <- mapM (deriveTraversalType tt ap) (map snd $ ctorDeclFields ctor)
return $ traverseFunc tt (PParen () $ PApp () (qname nam) (vars pVar 'a' arity))
$ traverseCtor tt nam (zipWith (App ()) tTypes (vars var 'a' arity))
-- | Derive a traversal for a type
deriveTraversalType :: TraveralType -> ArgPositions -> Type () -> WithInstances Trav
deriveTraversalType tt ap (TyParen () x) = deriveTraversalType tt ap x
deriveTraversalType tt ap TyForall{} = fail "forall not supported in traversal deriving"
deriveTraversalType tt ap (TyFun () a b)
= fromJust (traverseArrow tt)
<$> deriveTraversalType tt{traversalCo = not $ traversalCo tt} ap a
<*> deriveTraversalType tt ap b
deriveTraversalType tt ap (TyApp () a b) = deriveTraversalApp tt ap a [b] -- T a b c ...
deriveTraversalType tt ap (TyList () a) = deriveTraversalType tt ap $ TyApp () (TyCon () $ Special () $ ListCon ()) a
deriveTraversalType tt ap (TyTuple () b a) = deriveTraversalType tt ap $ tyApps (TyCon () $ Special () $ TupleCon () b $ length a) a
deriveTraversalType tt ap (TyCon () n) = return $ traversalId tt -- T
deriveTraversalType tt ap (TyVar () (Ident () n)) -- a
| ap n /= traversalArg tt = return $ traversalId tt
| traversalCo tt = fail "tyvar used in covariant position"
| otherwise = return $ traversalDirect tt
-- | Find all arguments to a type application, then derive a traversal
deriveTraversalApp :: TraveralType -> ArgPositions -> Type () -> [Type ()] -> WithInstances Trav
deriveTraversalApp tt ap (TyApp () a b) args = deriveTraversalApp tt ap a (b : args)
deriveTraversalApp tt ap tycon@TyTuple{} args = do -- (a,b,c)
tArgs <- mapM (deriveTraversalType tt ap) args
return $
if (all (== traversalId tt) tArgs) then
traversalId tt
else
Lambda () [PTuple () Boxed (vars pVar 't' (length args))]
(traverseTuple tt $ zipWith (App ()) tArgs (vars var 't' (length args)))
deriveTraversalApp tt ap tycon args = do -- T a b c
tCon <- deriveTraversalType tt ap tycon
tArgs <- mapM (deriveTraversalType tt ap) args
-- need instances?
case tycon of
TyVar () (Ident () n) | ap n == traversalArg tt -> fail "kind error: type used type constructor"
| otherwise -> tell $ S.fromList
[ RequiredInstance n i
| (t,i) <- zip (reverse tArgs) [1..]
, t /= traversalId tt
]
_ -> return ()
-- combine non-id traversals
let nonId = [ traverseArg tt i t
| (t,i) <- zip (reverse tArgs) [1..]
, t /= traversalId tt
]
return $ case nonId of
[] -> traversalId tt -- no interesting arguments to type con
_ -> foldl1 (traversalPlus tt) nonId
-- | Lift a traversal to the argument of a type constructor
traverseArg :: TraveralType -> Int -> Trav -> Trav
traverseArg tt n e = traversalFunc tt (traversalNameN tt n) e
traversalNameN :: TraveralType -> Int -> QName ()
traversalNameN tt n | n <= 1 = nm
| otherwise = nm `f` (if n > 1 then show n else "")
where nm = traversalName tt
f (Qual () m x) y = Qual () m $ x `g` y
f (UnQual () x) y = UnQual () $ x `g` y
g (Ident () x) y = Ident () $ x ++ y
-- | Information on argument positions
type ArgPositions = String -> Int
-- | Position of an argument in the data type
-- In the type "data X a b c"
-- positions are: a -> 3, b -> 2, c -> 1
argPositions :: DataDecl -> String -> Int
argPositions dat = \nm -> case elemIndex nm args of
Nothing -> error "impossible: tyvar not in scope"
Just k -> length args - k
where args = dataDeclVars dat
derive-2.6.5/src/Data/Derive/Is.hs 0000644 0000000 0000000 00000001752 07346545000 014765 0 ustar 00 0000000 0000000 module Data.Derive.Is(makeIs) where
{-
test :: Sample
isFirst :: Sample a -> Bool
isFirst (First{}) = True ; isFirst _ = False
isSecond :: Sample a -> Bool
isSecond (Second{}) = True ; isSecond _ = False
isThird :: Sample a -> Bool
isThird (Third{}) = True ; isThird _ = False
-}
import Language.Haskell
import Data.Derive.Internal.Derivation
makeIs :: Derivation
makeIs = derivationCustom "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d
makeIsCtor :: DataDecl -> CtorDecl -> [Decl ()]
makeIsCtor d c = if not $ isIdent $ ctorDeclName c then [] else
[TypeSig () [name nam] (TyFun () (dataDeclType d) (tyCon "Bool"))
,FunBind () $ match : [defMatch | length (dataDeclCtors d) > 1]]
where
nam = "is" ++ ctorDeclName c
match = Match () (name nam) [PParen () $ PRec () (qname $ ctorDeclName c) []] (UnGuardedRhs () $ con "True") Nothing
defMatch = Match () (name nam) [PWildCard ()] (UnGuardedRhs () $ con "False") Nothing
derive-2.6.5/src/Data/Derive/JSON.hs 0000644 0000000 0000000 00000016260 07346545000 015163 0 ustar 00 0000000 0000000 -- |
-- Copyright: (c) Bertram Felgenhauer 2009
-- License: BSD3
-- Stability: experimental
-- Portability: portable
--
-- Derive 'Text.JSON' instances.
--
-- Unlike Text.JSON.Generics, single constructor types are /not/ handled
-- specially. Every value is encoded as an object with a single field,
-- with the constructor name as key and the values as its contents.
--
-- If the constructor is a record, the contents is an Object with the
-- field names as keys. Otherwise, the contents is an array.
module Data.Derive.JSON (makeJSON) where
import qualified Language.Haskell as H
import Language.Haskell (
Exp, Pat, Alt, CtorDecl, Decl, FullDataDecl, FieldDecl, Type, Stmt,
(~=), var, pVar, con, strE, strP, apps, qname,
ctorDeclFields, ctorDeclName, dataDeclCtors)
{-
import "json" Text.JSON
import Text.JSON.Types
example :: Custom
instance JSON a => JSON (Sample a) where
readJSON (JSObject x) = $(readJSON)
readJSON _ = Error "..."
showJSON (First) = $(showJSON 0)
showJSON (Second x1 x2) = $(showJSON 1)
showJSON (Third x1) = $(showJSON 2)
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeJSON :: Derivation
makeJSON = derivationCustomDSL "JSON" custom $
List [Instance ["JSON"] "JSON" (App "Just" (List [List [App
"InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"
(List []),List [App "Match" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),String "readJSON"]),List [App "PParen" (
List [App "()" (List []),App "PApp" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "JSObject"])]),List [App "PVar" (List [App "()" (
List []),App "Ident" (List [App "()" (List []),String "x"])])]])])
],App "UnGuardedRhs" (List [App "()" (List []),App "SpliceExp" (
List [App "()" (List []),App "ParenSplice" (List [App "()" (List [
]),App "Var" (List [App "()" (List []),App "UnQual" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),String
"readJSON"])])])])])]),App "Nothing" (List [])]),App "Match" (List
[App "()" (List []),App "Ident" (List [App "()" (List []),String
"readJSON"]),List [App "PWildCard" (List [App "()" (List [])])],
App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App
"()" (List []),App "Con" (List [App "()" (List []),App "UnQual" (
List [App "()" (List []),App "Ident" (List [App "()" (List []),
String "Error"])])]),App "Lit" (List [App "()" (List []),App
"String" (List [App "()" (List []),String "...",String "..."])])])
]),App "Nothing" (List [])])]])]),App "InsDecl" (List [App "()" (
List []),App "FunBind" (List [App "()" (List []),MapCtor (App
"Match" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "showJSON"]),List [App "PParen" (List [App "()" (
List []),App "PApp" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),CtorName]
)]),MapField (App "PVar" (List [App "()" (List []),App "Ident" (
List [App "()" (List []),Concat (List [String "x",ShowInt
FieldIndex])])]))])])],App "UnGuardedRhs" (List [App "()" (List []
),App "SpliceExp" (List [App "()" (List []),App "ParenSplice" (
List [App "()" (List []),App "App" (List [App "()" (List []),App
"Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "showJSON"])])]),
App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (
List []),CtorIndex,ShowInt CtorIndex])])])])])]),App "Nothing" (
List [])]))])])]]))]
-- GENERATED STOP
-- ^ 'Derivation' for 'JSON'
custom :: FullDataDecl -> [Decl ()] -> [Decl ()]
custom = customSplice splice
splice :: FullDataDecl -> Exp () -> Exp ()
splice d x | x ~= "readJSON" = mkRead d
splice d (H.App _ x (H.Lit _ (H.Int _ y _))) | x~= "showJSON" = mkShow d y
splice _ e = error $ "makeJSON: unrecognized splice: " ++ show e
------------------------------------------------------------------------------
-- showJSON
mkShow :: FullDataDecl -> Integer -> Exp ()
mkShow d y = let
hasFields = any (not . null . fst) (ctorDeclFields c)
c = dataDeclCtors (snd d) !! fromInteger y
mkFields = if hasFields then mkShowRecordFields else mkShowPlainFields
in
mkJSObject $ H.List ()
[H.Tuple () H.Boxed [strE (ctorDeclName c), mkFields (ctorDeclFields c)]]
mkShowPlainFields :: FieldDecl -> Exp ()
mkShowPlainFields fs = mkJSArray $ H.List ()
[H.App () (var "showJSON") xi | xi <- vars "x" fs]
mkShowRecordFields :: FieldDecl -> Exp ()
mkShowRecordFields fs = mkJSObject $ H.List ()
[ H.Tuple () H.Boxed [strE fn, H.App () (var "showJSON") xi]
| ((fn, _), xi) <- zip fs (vars "x" fs)]
------------------------------------------------------------------------------
-- readJSON
mkRead :: FullDataDecl -> Exp ()
mkRead (_, d) = let
readError = H.App () (con "Error") $ strE "malformed JSON for type ...: ..."
in
H.Case () (H.App () (var "fromJSObject") $ var "x") $
map mkReadCtor (dataDeclCtors d) ++
[H.Alt () (H.PWildCard ()) (H.UnGuardedRhs () readError) Nothing]
mkReadCtor :: CtorDecl -> Alt ()
mkReadCtor c = let
cn = ctorDeclName c
fs = ctorDeclFields c
hasFields = any (not . null . fst) fs
body | hasFields = mkReadRecord cn fs
| otherwise = mkReadPlain cn fs
in
H.Alt () (H.PList () [H.PTuple () H.Boxed [strP cn, pVar "y"]])
(H.UnGuardedRhs () body) Nothing
mkReadRecord :: String -> FieldDecl -> Exp ()
mkReadRecord cn fs = H.Do () $
[H.Generator () (H.PApp () (qname "JSObject") [pVar "z"])
(H.App () (var "return") $ var "y")] ++
[H.LetStmt () $ H.BDecls () [H.PatBind () (pVar "d")
(H.UnGuardedRhs () $ H.App () (var "fromJSObject") $ var "z")
Nothing]] ++
zipWith (mkReadRecordField cn) (pVars "x" fs) fs ++
mkReadTrailer cn fs
mkReadRecordField :: String -> Pat () -> (String, Type ()) -> Stmt ()
mkReadRecordField cn xi (fn, _) = H.Generator () xi $
apps (var "maybe") [
H.App () (var "fail") $ strE (unwords ["readJSON: missing field", fn,
"while decoding a", cn]),
var "return",
apps (var "lookup") [strE fn, var "d"]]
mkReadPlain :: String -> FieldDecl -> Exp ()
mkReadPlain cn fs = H.Do () $
[H.Generator () (H.PApp () (qname "JSArray") [H.PList () (pVars "x" fs)])
(H.App () (var "return") $ var "y")] ++
mkReadTrailer cn fs
mkReadTrailer :: String -> FieldDecl -> [Stmt ()]
mkReadTrailer cn fs =
[ H.Generator () yi (H.App () (var "readJSON") xi)
| (xi, yi) <- zip (vars "x" fs) (pVars "y" fs)] ++
[H.Qualifier () $ H.App () (var "return") $ apps (con cn) (vars "y" fs)]
------------------------------------------------------------------------------
-- utilites
mkJSObject :: Exp () -> Exp ()
mkJSObject e = H.App () (con "JSObject") (H.App () (var "toJSObject") e)
mkJSArray :: Exp () -> Exp ()
mkJSArray e = H.App () (con "JSArray") e
vars :: String -> FieldDecl -> [Exp ()]
vars pre fs = [var (pre ++ show i) | i <- [1..length fs]]
pVars :: String -> FieldDecl -> [Pat ()]
pVars pre fs = [pVar (pre ++ show i) | i <- [1..length fs]]
derive-2.6.5/src/Data/Derive/LazySet.hs 0000644 0000000 0000000 00000002535 07346545000 016005 0 ustar 00 0000000 0000000 {-|
A pseudo derivation. For each field in the data type, deriving
@LazySet@ generates a function like a record updator, but lazy where possible.
This is very useful in certain situations to improve laziness
properties. A setter is only lazy if that field is present in one constructor.
-}
module Data.Derive.LazySet(makeLazySet) where
{-
test :: Computer
setSpeed :: Int -> Computer -> Computer
setSpeed v x = x{speed=v}
setWeight :: Double -> Computer -> Computer
setWeight v x = Laptop v (speed x)
test :: Sample
-}
import Language.Haskell
import Data.Derive.Internal.Derivation
makeLazySet :: Derivation
makeLazySet = derivationCustom "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d
makeLazySetField :: DataDecl -> String -> [Decl ()]
makeLazySetField d field = if isIdent field then [TypeSig () [name fun] typ, bind fun [pVar "v",pVar "x"] bod] else []
where
fun = "set" ++ title field
tyFun = TyFun ()
typ = t `tyFun` (dataDeclType d `tyFun` dataDeclType d)
(t,c):tc = [(t,c) | c <- dataDeclCtors d, (n,t) <- ctorDeclFields c, n == field]
bod | null tc = apps (con $ ctorDeclName c) [n == field ? var "v" $ Paren () $ App () (var n) (var "x") | (n,t) <- ctorDeclFields c]
| otherwise = RecUpdate () (var "x") [FieldUpdate () (qname field) (var "v")]
derive-2.6.5/src/Data/Derive/Lens.hs 0000644 0000000 0000000 00000002256 07346545000 015313 0 ustar 00 0000000 0000000 {-|
A pseudo derivation. For each field in the data type, deriving
@Lens@ generates @lens@/FieldName/@ = lens @/fieldName/@
(\ x v -> v { @/fieldName/@ = x })@.
This works with the @data-lens@ package.
-}
module Data.Derive.Lens(makeLens) where
{-
import "data-lens" Data.Lens.Common
test :: Sample
test :: Computer
lensSpeed :: Lens Computer Int
lensSpeed = lens speed (\x v -> v{speed = x})
lensWeight :: Lens Computer Double
lensWeight = lens weight (\x v -> v{weight = x})
-}
import Language.Haskell
import Data.Derive.Internal.Derivation
makeLens :: Derivation
makeLens = derivationCustom "Lens" $ \(_,d) -> Right $ concatMap (makeLensField d) $ dataDeclFields d
makeLensField :: DataDecl -> String -> [Decl ()]
makeLensField d field = if isIdent field then [TypeSig () [name ref] typ, bind ref [] bod] else []
where
ref = "lens" ++ title field
typ = tyApps (tyCon "Lens") [dataDeclType d, t]
Just t = lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
bod = apps (var "lens")
[var field
,Paren () $ Lambda () [pVar "x",pVar "v"] $ RecUpdate () (var "v") [FieldUpdate () (qname field) (var "x")]]
derive-2.6.5/src/Data/Derive/Monoid.hs 0000644 0000000 0000000 00000012314 07346545000 015633 0 ustar 00 0000000 0000000 {-|
Derives an instance of @Monoid@. It uses the product
construction of monoids. @mappend@ on two different constructors
is undefined.
-}
module Data.Derive.Monoid(makeMonoid) where
{-
import Data.Monoid hiding (First)
example :: Sample
instance Monoid a => Monoid (Sample a) where
mempty = head [First, Second (const mempty 1) (const mempty 2), Third (const mempty 1)]
mappend (First) (First) = First
mappend (Second x1 x2) (Second y1 y2) = Second (mappend x1 y1) (mappend x2 y2)
mappend (Third x1) (Third y1) = Third (mappend x1 y1)
mappend _ _ | length [First{},Second{},Third{}] > 1 = error "Monoid.mappend: Different constructors for Sample"
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeMonoid :: Derivation
makeMonoid = derivationDSL "Monoid" dslMonoid
dslMonoid =
List [Instance ["Monoid"] "Monoid" (App "Just" (List [List [App
"InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"
(List []),App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),String "mempty"])]),App "UnGuardedRhs" (List [
App "()" (List []),App "App" (List [App "()" (List []),App "Var" (
List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),String "head"])])]),App
"List" (List [App "()" (List []),MapCtor (Application (Concat (
List [List [App "Con" (List [App "()" (List []),App "UnQual" (List
[App "()" (List []),App "Ident" (List [App "()" (List []),CtorName
])])])],MapField (App "Paren" (List [App "()" (List []),
Application (List [App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "const"])])]),App "Var" (List [App "()" (List []),
App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),String "mempty"])])]),App "Lit" (List [App "()" (List []
),App "Int" (List [App "()" (List []),FieldIndex,ShowInt
FieldIndex])])])]))])))])])]),App "Nothing" (List [])])]),App
"InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"
(List []),Concat (List [MapCtor (App "Match" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "mappend"]),List
[App "PParen" (List [App "()" (List []),App "PApp" (List [App "()"
(List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),CtorName])]),MapField (App "PVar" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),Concat (List
[String "x",ShowInt FieldIndex])])]))])]),App "PParen" (List [App
"()" (List []),App "PApp" (List [App "()" (List []),App "UnQual" (
List [App "()" (List []),App "Ident" (List [App "()" (List []),
CtorName])]),MapField (App "PVar" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),Concat (List [String "y",ShowInt
FieldIndex])])]))])])],App "UnGuardedRhs" (List [App "()" (List []
),Application (Concat (List [List [App "Con" (List [App "()" (List
[]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),CtorName])])])],MapField (App "Paren" (List [App
"()" (List []),Application (List [App "Var" (List [App "()" (List
[]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),String "mappend"])])]),App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])]
)])]),App "Var" (List [App "()" (List []),App "UnQual" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),Concat (List
[String "y",ShowInt FieldIndex])])])])])]))]))]),App "Nothing" (
List [])])),List [App "Match" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "mappend"]),List [App
"PWildCard" (List [App "()" (List [])]),App "PWildCard" (List [App
"()" (List [])])],App "GuardedRhss" (List [App "()" (List []),List
[App "GuardedRhs" (List [App "()" (List []),List [App "Qualifier"
(List [App "()" (List []),App "InfixApp" (List [App "()" (List [])
,App "App" (List [App "()" (List []),App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "length"])])]),App "List" (List [App
"()" (List []),MapCtor (App "RecConstr" (List [App "()" (List []),
App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),CtorName])]),List []]))])]),App "QVarOp" (List [App "()"
(List []),App "UnQual" (List [App "()" (List []),App "Symbol" (
List [App "()" (List []),String ">"])])]),App "Lit" (List [App
"()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (
Int 1)])])])])],App "App" (List [App "()" (List []),App "Var" (
List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),String "error"])])]),App
"Lit" (List [App "()" (List []),App "String" (List [App "()" (List
[]),Concat (List [String
"Monoid.mappend: Different constructors for ",DataName]),Concat (
List [String "Monoid.mappend: Different constructors for ",
DataName])])])])])]]),App "Nothing" (List [])])]])])])]]))]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/NFData.hs 0000644 0000000 0000000 00000003513 07346545000 015504 0 ustar 00 0000000 0000000 module Data.Derive.NFData where
{-
import "deepseq" Control.DeepSeq(NFData, rnf)
example :: Sample
instance NFData a => NFData (Sample a) where
rnf (First) = ()
rnf (Second x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
rnf (Third x1) = rnf x1 `seq` ()
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeNFData :: Derivation
makeNFData = derivationDSL "NFData" dslNFData
dslNFData =
List [Instance ["NFData"] "NFData" (App "Just" (List [List [App
"InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"
(List []),MapCtor (App "Match" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "rnf"]),List [App
"PParen" (List [App "()" (List []),App "PApp" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),CtorName])]),MapField (App "PVar" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),Concat (List
[String "x",ShowInt FieldIndex])])]))])])],App "UnGuardedRhs" (
List [App "()" (List []),Fold (App "InfixApp" (List [App "()" (
List []),Head,App "QVarOp" (List [App "()" (List []),App "UnQual"
(List [App "()" (List []),App "Ident" (List [App "()" (List []),
String "seq"])])]),Tail])) (Concat (List [MapField (App "App" (
List [App "()" (List []),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "rnf"])])]),App "Var" (List [App "()" (List []),
App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),Concat (List [String "x",ShowInt FieldIndex])])])])])),
List [App "Con" (List [App "()" (List []),App "Special" (List [App
"()" (List []),App "UnitCon" (List [App "()" (List [])])])])]]))])
,App "Nothing" (List [])]))])])]]))]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/Ref.hs 0000644 0000000 0000000 00000002613 07346545000 015123 0 ustar 00 0000000 0000000 {-|
A pseudo derivation. For each field in the data type, deriving
@Ref@ generates @ref@/FieldName/@ = Ref { select = @/fieldName/@ , update =
\ f v -> v { @/fieldName/@ = f (@/fieldName/@ v) } }@.
This is intended for use with the compositional functional references
described in
.
-}
module Data.Derive.Ref(makeRef) where
{-
test :: Sample
test :: Computer
refSpeed :: Ref Computer
refSpeed = Ref {select = speed, update = \f v -> v{speed = f (speed v)}}
refWeight :: Ref Computer
refWeight = Ref {select = weight, update = \f v -> v{weight = f (weight v)}}
-}
import Language.Haskell
import Data.Derive.Internal.Derivation
makeRef :: Derivation
makeRef = derivationCustom "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d
makeRefField :: DataDecl -> String -> [Decl ()]
makeRefField d field = if isIdent field then [TypeSig () [name ref] typ, bind ref [] bod] else []
where
ref = "ref" ++ title field
typ = TyApp () (tyCon "Ref") (dataDeclType d)
bod = RecConstr () (qname "Ref")
[FieldUpdate () (qname "select") (var field)
,FieldUpdate () (qname "update") $ Lambda () [pVar "f",pVar "v"] $
RecUpdate () (var "v") [FieldUpdate () (qname field) $ App () (var "f") $ Paren () $ App () (var field) (var "v")]
]
derive-2.6.5/src/Data/Derive/Serial.hs 0000644 0000000 0000000 00000010531 07346545000 015624 0 ustar 00 0000000 0000000 module Data.Derive.Serial where
{-
import "smallcheck" Test.SmallCheck
example :: Sample
instance Serial a => Serial (Sample a) where
series = cons0 First \/
cons2 Second \/
cons1 Third
coseries rs d = [ \t -> case t of
First -> t0
Second x1 x2 -> t1 x1 x2
Third x1 -> t2 x1
| t0 <- alts0 rs d `const` First{}
, t1 <- alts2 rs d `const` Second{}
, t2 <- alts1 rs d `const` Third{}
]
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeSerial :: Derivation
makeSerial = derivationDSL "Serial" dslSerial
dslSerial =
List [Instance ["Serial"] "Serial" (App "Just" (List [List [App
"InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"
(List []),App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),String "series"])]),App "UnGuardedRhs" (List [
App "()" (List []),Fold (App "InfixApp" (List [App "()" (List []),
Tail,App "QVarOp" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Symbol" (List [App "()" (List []),String
"\\/"])])]),Head])) (Reverse (MapCtor (App "App" (List [App "()" (
List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),Concat (
List [String "cons",ShowInt CtorArity])])])]),App "Con" (List [App
"()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),CtorName])])])]))))]),App "Nothing" (
List [])])]),App "InsDecl" (List [App "()" (List []),App "FunBind"
(List [App "()" (List []),List [App "Match" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "coseries"]),List
[App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),String "rs"])]),App "PVar" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "d"])])],App
"UnGuardedRhs" (List [App "()" (List []),App "ListComp" (List [App
"()" (List []),App "Lambda" (List [App "()" (List []),List [App
"PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List
[]),String "t"])])],App "Case" (List [App "()" (List []),App "Var"
(List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),String "t"])])]),MapCtor (
App "Alt" (List [App "()" (List []),App "PApp" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),CtorName])]),MapField (App "PVar" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),Concat (List
[String "x",ShowInt FieldIndex])])]))]),App "UnGuardedRhs" (List [
App "()" (List []),Application (Concat (List [List [App "Var" (
List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),Concat (List [String "t",
ShowInt CtorIndex])])])])],MapField (App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])]
)])]))]))]),App "Nothing" (List [])]))])]),MapCtor (App "QualStmt"
(List [App "()" (List []),App "Generator" (List [App "()" (List []
),App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),Concat (List [String "t",ShowInt CtorIndex])])]),App
"InfixApp" (List [App "()" (List []),Application (List [App "Var"
(List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),Concat (List [String "alts",
ShowInt CtorArity])])])]),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "rs"])])]),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "d"])])])]),App "QVarOp" (List [App "()" (List [])
,App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),String "const"])])]),App "RecConstr" (List [App
"()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),CtorName])]),List []])])])]))])]),App
"Nothing" (List [])])]])])]]))]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/Serialize.hs 0000644 0000000 0000000 00000023431 07346545000 016337 0 ustar 00 0000000 0000000 module Data.Derive.Serialize where
{-
import "cereal" Data.Serialize
example :: Sample
instance Serialize alpha => Serialize (Sample alpha) where
put x = case x of
First -> do putTag 0
Second x1 x2 -> do putTag 1 ; put x1 ; put x2
Third x1 -> do putTag 2 ; put x1
where
useTag = length [First{}, Second{}, Third{}] > 1
putTag x = when useTag (putWord8 x)
get = do
i <- getTag
case i of
0 -> do return (First)
1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)
2 -> do x1 <- get ; return (Third x1)
_ -> error "Corrupted binary data for Sample"
where
useTag = length [First{}, Second{}, Third{}] > 1
getTag = if useTag then getWord8 else return 0
test :: List
instance Serialize a => Serialize (List a) where
put x = case x of
Nil -> putWord8 0
Cons x1 x2 -> do putWord8 1; put x1; put x2
get = do
i <- getWord8
case i of
0 -> return Nil
1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)
_ -> error "Corrupted binary data for List"
test :: Assoced
instance Serialize typ => Serialize (Assoced typ) where
put (Assoced x1 x2) = do put x1; put x2
get = do x1 <- get; x2 <- get; return (Assoced x1 x2)
-}
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeSerialize :: Derivation
makeSerialize = derivationDSL "Serialize" dslSerialize
dslSerialize =
List [Instance ["Serialize"] "Serialize" (App "Just" (List [List [
App "InsDecl" (List [App "()" (List []),App "FunBind" (List [App
"()" (List []),List [App "Match" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "put"]),List [App "PVar"
(List [App "()" (List []),App "Ident" (List [App "()" (List []),
String "x"])])],App "UnGuardedRhs" (List [App "()" (List []),App
"Case" (List [App "()" (List []),App "Var" (List [App "()" (List [
]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),String "x"])])]),MapCtor (App "Alt" (List [App "()"
(List []),App "PApp" (List [App "()" (List []),App "UnQual" (List
[App "()" (List []),App "Ident" (List [App "()" (List []),CtorName
])]),MapField (App "PVar" (List [App "()" (List []),App "Ident" (
List [App "()" (List []),Concat (List [String "x",ShowInt
FieldIndex])])]))]),App "UnGuardedRhs" (List [App "()" (List []),
App "Do" (List [App "()" (List []),Concat (List [List [App
"Qualifier" (List [App "()" (List []),App "App" (List [App "()" (
List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"putTag"])])]),App "Lit" (List [App "()" (List []),App "Int" (List
[App "()" (List []),CtorIndex,ShowInt CtorIndex])])])])],MapField
(App "Qualifier" (List [App "()" (List []),App "App" (List [App
"()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (
List [App "()" (List []),App "Ident" (List [App "()" (List []),
String "put"])])]),App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),Concat (List [String "x",ShowInt FieldIndex])])])])])]))]
)])]),App "Nothing" (List [])]))])]),App "Just" (List [App
"BDecls" (List [App "()" (List []),List [App "PatBind" (List [App
"()" (List []),App "PVar" (List [App "()" (List []),App "Ident" (
List [App "()" (List []),String "useTag"])]),App "UnGuardedRhs" (
List [App "()" (List []),App "InfixApp" (List [App "()" (List []),
App "App" (List [App "()" (List []),App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "length"])])]),App "List" (List [App
"()" (List []),MapCtor (App "RecConstr" (List [App "()" (List []),
App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),CtorName])]),List []]))])]),App "QVarOp" (List [App "()"
(List []),App "UnQual" (List [App "()" (List []),App "Symbol" (
List [App "()" (List []),String ">"])])]),App "Lit" (List [App
"()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (
Int 1)])])])]),App "Nothing" (List [])]),App "FunBind" (List [App
"()" (List []),List [App "Match" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "putTag"]),List [App
"PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List
[]),String "x"])])],App "UnGuardedRhs" (List [App "()" (List []),
Application (List [App "Var" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "when"])])]),App "Var" (List [App "()" (List []),
App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),String "useTag"])])]),App "Paren" (List [App "()" (List
[]),App "App" (List [App "()" (List []),App "Var" (List [App "()"
(List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),Concat (List [String "putWord",ShowInt (Int 8)
])])])]),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"x"])])])])])])]),App "Nothing" (List [])])]])]])])])]])]),App
"InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"
(List []),App "PVar" (List [App "()" (List []),App "Ident" (List [
App "()" (List []),String "get"])]),App "UnGuardedRhs" (List [App
"()" (List []),App "Do" (List [App "()" (List []),List [App
"Generator" (List [App "()" (List []),App "PVar" (List [App "()" (
List []),App "Ident" (List [App "()" (List []),String "i"])]),App
"Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),String "getTag"])])])]),
App "Qualifier" (List [App "()" (List []),App "Case" (List [App
"()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (
List [App "()" (List []),App "Ident" (List [App "()" (List []),
String "i"])])]),Concat (List [MapCtor (App "Alt" (List [App "()"
(List []),App "PLit" (List [App "()" (List []),App "Signless" (
List [App "()" (List [])]),App "Int" (List [App "()" (List []),
CtorIndex,ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()"
(List []),App "Do" (List [App "()" (List []),Concat (List [
MapField (App "Generator" (List [App "()" (List []),App "PVar" (
List [App "()" (List []),App "Ident" (List [App "()" (List []),
Concat (List [String "x",ShowInt FieldIndex])])]),App "Var" (List
[App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "get"])])])])),List [App
"Qualifier" (List [App "()" (List []),App "App" (List [App "()" (
List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"return"])])]),App "Paren" (List [App "()" (List []),Application (
Concat (List [List [App "Con" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),CtorName])])])],MapField (App "Var" (List [App "()" (List
[]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])
)]))])])])]])])]),App "Nothing" (List [])])),List [App "Alt" (List
[App "()" (List []),App "PWildCard" (List [App "()" (List [])]),
App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App
"()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (
List [App "()" (List []),App "Ident" (List [App "()" (List []),
String "error"])])]),App "Lit" (List [App "()" (List []),App
"String" (List [App "()" (List []),Concat (List [String
"Corrupted binary data for ",DataName]),Concat (List [String
"Corrupted binary data for ",DataName])])])])]),App "Nothing" (
List [])])]])])])]])]),App "Just" (List [App "BDecls" (List [App
"()" (List []),List [App "PatBind" (List [App "()" (List []),App
"PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List
[]),String "useTag"])]),App "UnGuardedRhs" (List [App "()" (List [
]),App "InfixApp" (List [App "()" (List []),App "App" (List [App
"()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (
List [App "()" (List []),App "Ident" (List [App "()" (List []),
String "length"])])]),App "List" (List [App "()" (List []),MapCtor
(App "RecConstr" (List [App "()" (List []),App "UnQual" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),CtorName])]),
List []]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual"
(List [App "()" (List []),App "Symbol" (List [App "()" (List []),
String ">"])])]),App "Lit" (List [App "()" (List []),App "Int" (
List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]),App
"Nothing" (List [])]),App "PatBind" (List [App "()" (List []),App
"PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List
[]),String "getTag"])]),App "UnGuardedRhs" (List [App "()" (List [
]),App "If" (List [App "()" (List []),App "Var" (List [App "()" (
List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),String "useTag"])])]),App "Var" (List [App
"()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"
(List [App "()" (List []),Concat (List [String "getWord",ShowInt (
Int 8)])])])]),App "App" (List [App "()" (List []),App "Var" (List
[App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "return"])])]),App "Lit"
(List [App "()" (List []),App "Int" (List [App "()" (List []),Int
0,ShowInt (Int 0)])])])])]),App "Nothing" (List [])])]])])])])]]))
]
-- GENERATED STOP
derive-2.6.5/src/Data/Derive/Set.hs 0000644 0000000 0000000 00000002232 07346545000 015137 0 ustar 00 0000000 0000000 {-|
A pseudo derivation. For each field in the data type, deriving
@Set@ generates @set@/FieldName/@ v x = x{@/fieldName/@ = v}@.
This derivation is intended to work around the fact that in Haskell
assigning to a field is not a first class object (although
extracting from a field is).
-}
module Data.Derive.Set(makeSet) where
{-
test :: Computer
setSpeed :: Int -> Computer -> Computer
setSpeed v x = x{speed=v}
setWeight :: Double -> Computer -> Computer
setWeight v x = x{weight=v}
test :: Sample
-}
import Language.Haskell
import Data.Derive.Internal.Derivation
import Data.Maybe
makeSet :: Derivation
makeSet = derivationCustom "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d
makeSetField :: DataDecl -> String -> [Decl ()]
makeSetField d field = [TypeSig () [name set] typ, bind set [pVar "v",pVar "x"] bod]
where
set = "set" ++ title field
tyFun = TyFun ()
typ = typField `tyFun` (dataDeclType d `tyFun` dataDeclType d)
typField = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
bod = RecUpdate () (var "x") [FieldUpdate () (qname field) (var "v")]
derive-2.6.5/src/Data/Derive/UniplateDirect.hs 0000644 0000000 0000000 00000020506 07346545000 017324 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards #-}
-- NOTE: Cannot be guessed as it relies on type information
-- | Derive Uniplate and Biplate using the Direct combinators.
-- You must request monomorphic instances, i.e:
--
-- > data Foo a = Foo a (Bool, a)
-- >
-- > {-!
-- > deriving instance UniplateDirect (Foo Int)
-- > deriving instance UniplateDirect (Bool, Int) Int
-- > deriving instance UniplateDirect (Foo Int) Int
-- > !-}
--
-- This will generate the instances @Uniplate (Foo Int)@,
-- @Biplate (Bool, Int) Int@ and @Biplate (Foo Int) Int@.
-- Generally, start with the instance you are after (e.g. @UniplateDirect (Foo Int)@),
-- try to compile and add further instances as necessary. @UniplateDirect@ with
-- one argument derives Uniplate, and with two arguments derives Biplate.
--
-- @deriving UniplateDirect@ on a data type with no arguments derives Uniplate
-- with all type parameters defaulting to @()@.
module Data.Derive.UniplateDirect(makeUniplateDirect) where
{-
import "uniplate" Data.Generics.Uniplate.Direct
-- test tuples
test :: UniplateDirect ((), Maybe ()) ()
instance Biplate ((), Maybe ()) () where
{-# INLINE biplate #-}
biplate (x1, x2) = plate (,) |* x1 |+ x2
test :: UniplateDirect (Sample Int)
instance Uniplate (Sample Int) where
{-# INLINE uniplate #-}
uniplate x = plate x
test :: UniplateDirect (Sample Int) Int
instance Biplate (Sample Int) Int where
{-# INLINE biplate #-}
biplate (Second x1 x2) = plate Second |* x1 |* x2
biplate (Third x1) = plate Third |* x1
biplate x = plate x
test :: UniplateDirect Computer
instance Uniplate Computer where
{-# INLINE uniplate #-}
uniplate x = plate x
test :: UniplateDirect Computer Computer
instance Biplate Computer Computer where
{-# INLINE biplate #-}
biplate = plateSelf
test :: UniplateDirect Computer Double
instance Biplate Computer Double where
{-# INLINE biplate #-}
biplate (Laptop x1 x2) = plate Laptop |* x1 |- x2
biplate x = plate x
test :: UniplateDirect (Assoced (Maybe Bool)) Char
instance Biplate (Assoced (Maybe Bool)) Char where
{-# INLINE biplate #-}
biplate (Assoced x1 x2) = plate (Assoced x1) ||* x2
-- test following external declarations
test :: UniplateDirect (Either Bool Computer) Int
instance Biplate (Either Bool Computer) Int where
{-# INLINE biplate #-}
biplate (Right x1) = plate Right |+ x1
biplate x = plate x
-- test recursive bits
test :: UniplateDirect (List Int) Bool
instance Biplate (List Int) Bool where
{-# INLINE biplate #-}
biplate x = plate x
-}
import Language.Haskell
import Data.Generics.Uniplate.DataOnly
import Data.Derive.Internal.Derivation
import Data.Maybe
import qualified Data.Map as Map
import Control.Arrow
import Control.Monad.Trans.State
makeUniplateDirect :: Derivation
makeUniplateDirect = derivationParams "UniplateDirect" $ \args grab (_,ty) -> simplify $
let known = map (declName &&& id) knownCtors
grab2 x = fromMaybe (grab x) $ lookup x known
in case args of
_ | not $ null [() | TyVar () _ <- universeBi args] -> error "UniplateDirect only accepts monomorphic types"
[] -> make True grab2 x x
where x = tyApps (tyCon $ dataDeclName ty) $ replicate (dataDeclArity ty) $ TyCon () $ Special () (UnitCon ())
[x] -> make True grab2 x x
[x,y] -> make False grab2 x y
_ -> error $ "UniplateDirect requires exactly one or two arguments, got " ++ show (length args)
-- alwaysActive :: Activation ()
-- alwaysActive = ActiveFrom () 0
make :: Bool -> (String -> DataDecl) -> Type () -> Type () -> Either String [Decl ()]
make uni grab from to =
Right [InstDecl () Nothing instRule
(Just [InsDecl () $ InlineSig () True Nothing (qname $ if uni then "uniplate" else "biplate"), InsDecl () ms])]
where
headName = (UnQual () $ Ident () $ if uni then "Uniplate" else "Biplate")
instRule = IRule () Nothing Nothing (foldr (flip (IHApp ())) (IHCon () headName) (from : [to | not uni]))
ty = grab $ tyRoot from
match pat bod = Match () (Ident () $ if uni then "uniplate" else "biplate") [pat] (UnGuardedRhs () bod) Nothing
ms = if uni || from /= to
then FunBind () $ map (uncurry match) (catMaybes bods) ++ [match (pVar "x") (App () (var "plate") (var "x")) | any isNothing bods]
else PatBind () (pVar "biplate") (UnGuardedRhs () $ var "plateSelf") Nothing
bods = run (fromTyParens to) $ mapM (make1 grab) $ substData from ty
make1 :: (String -> DataDecl) -> (String,[Type ()]) -> S (Maybe (Pat (), Exp ()))
make1 grab (name,tys) = do
ops <- mapM (fmap show . operator grab) tys
let vars = ['x':show i | i <- [1..length tys]]
pat = PParen () $ PApp () (qname name) $ map pVar vars
(good,bad) = span ((==) "|-" . fst) $ zip ops $ map var vars
bod = foldl (\x (y,z) -> InfixApp () x (QVarOp () $ UnQual () $ Symbol () y) z) (App () (var "plate") $ paren $ apps (con name) (map snd good)) bad
return $ if all (== "|-") ops then Nothing else Just (pat,bod)
data Ans = Hit | Miss | Try | ListHit | ListTry deriving Eq
instance Show Ans where
show Hit = "|*"
show Miss = "|-"
show Try = "|+"
show ListHit = "||*"
show ListTry = "||+"
ansList Hit = ListHit
ansList Miss = Miss
ansList _ = ListTry
ansJoin (Miss:xs) = ansJoin xs
ansJoin [] = Miss
ansJoin _ = Try
type S a = State (Map.Map (Type ()) Ans) a
run :: Type () -> S a -> a
run to act = evalState act (Map.singleton to Hit)
operator :: (String -> DataDecl) -> Type () -> S Ans
operator grab from = do
mp <- get
case Map.lookup from mp of
Just y -> return y
Nothing -> do
fix Miss
where
fix ans = do
s <- get
modify $ Map.insert from ans
ans2 <- operator2 grab from
if ans == ans2
then return ans
else put s >> fix ans2
operator2 :: (String -> DataDecl) -> Type () -> S Ans
operator2 grab from
| isTyFun from = return Try
| Just from2 <- fromTyList from = fmap ansList $ operator grab from2
| otherwise = case subst from $ grab $ tyRoot from of
Left from2 -> operator grab from2
Right ctrs -> fmap ansJoin $ mapM (operator grab) $ concatMap snd ctrs
subst :: Type () -> Decl () -> Either (Type ()) [(String,[Type ()])]
subst ty x@TypeDecl{} = Left $ substType ty x
subst ty x = Right $ substData ty x
substData :: Type () -> Decl () -> [(String,[Type ()])]
substData ty dat = [(ctorDeclName x, map (fromTyParens . transform f . snd) $ ctorDeclFields x) | x <- dataDeclCtors dat]
where
rep = zip (dataDeclVars dat) (snd $ fromTyApps $ fromTyParen ty)
f (TyVar () x) = fromMaybe (TyVar () x) $ lookup (prettyPrint x) rep
f x = x
substType :: Type () -> Decl () -> Type ()
substType ty (TypeDecl () dhead d) = fromTyParens $ transform f d
where
vars = collect dhead
rep = zip (map prettyPrint vars) (snd $ fromTyApps ty)
f (TyVar () x) = fromMaybe (TyVar () x) $ lookup (prettyPrint x) rep
f x = x
collect (DHead () _) = []
collect (DHInfix () bind _) = [bind]
collect (DHParen () h) = collect h
collect (DHApp () h bind) = bind : collect h
clearAnn :: Functor f => f a -> f ()
clearAnn = fmap (const ())
knownCtors :: [Decl ()]
knownCtors = map (fromParseResult . fmap clearAnn . parseDecl)
["data Int = Int"
,"data Bool = Bool"
,"data Char = Char"
,"data Double = Double"
,"data Float = Float"
,"data Integer = Integer"
,"data Maybe a = Nothing | Just a"
,"data Either a b = Left a | Right b"
,"type Rational = Ratio Integer"
,"data (Integral a) => Ratio a = !a :% !a"
,"type String = [Char]"
] ++
listCtor :
map tupleDefn (0:[2..32])
listCtor = DataDecl () (DataType ()) Nothing (DHApp () (DHead () $ Ident () "[]") (UnkindedVar () $ Ident () "a"))
[QualConDecl () Nothing Nothing $ ConDecl () (Ident () "[]") []
,QualConDecl () Nothing Nothing $ ConDecl () (Ident () "(:)") [tyVar "a", TyList () $ tyVar "a"]] []
tupleDefn :: Int -> Decl ()
tupleDefn n = DataDecl () (DataType ()) Nothing dhead [QualConDecl () Nothing Nothing $ ConDecl () (Ident () s) (map tyVar vars)] []
where s = "(" ++ replicate (n - 1) ',' ++ ")"
vars = ['v':show i | i <- [1..n]]
dhead = foldr (flip (DHApp ())) (DHead () $ Ident () s) (map (UnkindedVar () . Ident ()) vars)
derive-2.6.5/src/Data/Derive/UniplateTypeable.hs 0000644 0000000 0000000 00000012470 07346545000 017660 0 ustar 00 0000000 0000000 module Data.Derive.UniplateTypeable where
{-
import "uniplate" Data.Generics.Uniplate.Typeable
example :: Custom
instance (Typeable a, PlateAll a to, Uniplate to, Typeable to) => PlateAll (Sample a) to where
plateAll (First) = plate First
plateAll (Second x1 x2) = plate Second |+ x1 |+ x2
plateAll (Third x1) = plate Third |+ x1
test :: Bool
instance (Typeable to, Uniplate to) => PlateAll Bool to where
plateAll False = plate False
plateAll True = plate True
test :: Either a b
instance (Typeable a, PlateAll a to, Typeable b, PlateAll b to, Typeable to, Uniplate to) => PlateAll (Either a b) to where
plateAll (Left x1) = plate Left |+ x1
plateAll (Right x1) = plate Right |+ x1
-}
import Data.Derive.DSL.HSE
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeUniplateTypeable :: Derivation
makeUniplateTypeable = derivationCustomDSL "UniplateTypeable" custom $
List [App "InstDecl" (List [App "()" (List []),App "Nothing" (List
[]),App "IRule" (List [App "()" (List []),App "Nothing" (List []),
App "Just" (List [App "CxTuple" (List [App "()" (List []),List [
App "ClassA" (List [App "()" (List []),App "UnQual" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),String
"Typeable"])]),List [App "TyVar" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "a"])])]]),App "ClassA" (
List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),String "PlateAll"])]),List [
App "TyVar" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),String "a"])]),App "TyVar" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),String "to"])])]]),App "ClassA"
(List [App "()" (List []),App "UnQual" (List [App "()" (List []),
App "Ident" (List [App "()" (List []),String "Uniplate"])]),List [
App "TyVar" (List [App "()" (List []),App "Ident" (List [App "()"
(List []),String "to"])])]]),App "ClassA" (List [App "()" (List []
),App "UnQual" (List [App "()" (List []),App "Ident" (List [App
"()" (List []),String "Typeable"])]),List [App "TyVar" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),String "to"])
])]])]])]),App "IHApp" (List [App "()" (List []),App "IHApp" (List
[App "()" (List []),App "IHCon" (List [App "()" (List []),App
"UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
List []),String "PlateAll"])])]),App "TyParen" (List [App "()" (
List []),App "TyApp" (List [App "()" (List []),App "TyCon" (List [
App "()" (List []),App "UnQual" (List [App "()" (List []),App
"Ident" (List [App "()" (List []),DataName])])]),App "TyVar" (List
[App "()" (List []),App "Ident" (List [App "()" (List []),String
"a"])])])])]),App "TyVar" (List [App "()" (List []),App "Ident" (
List [App "()" (List []),String "to"])])])]),App "Just" (List [
List [App "InsDecl" (List [App "()" (List []),App "FunBind" (List
[App "()" (List []),MapCtor (App "Match" (List [App "()" (List [])
,App "Ident" (List [App "()" (List []),String "plateAll"]),List [
App "PParen" (List [App "()" (List []),App "PApp" (List [App "()"
(List []),App "UnQual" (List [App "()" (List []),App "Ident" (List
[App "()" (List []),CtorName])]),MapField (App "PVar" (List [App
"()" (List []),App "Ident" (List [App "()" (List []),Concat (List
[String "x",ShowInt FieldIndex])])]))])])],App "UnGuardedRhs" (
List [App "()" (List []),Fold (App "InfixApp" (List [App "()" (
List []),Tail,App "QVarOp" (List [App "()" (List []),App "UnQual"
(List [App "()" (List []),App "Symbol" (List [App "()" (List []),
String "|+"])])]),Head])) (Concat (List [Reverse (MapField (App
"Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
[]),App "Ident" (List [App "()" (List []),Concat (List [String "x"
,ShowInt FieldIndex])])])]))),List [App "App" (List [App "()" (
List []),App "Var" (List [App "()" (List []),App "UnQual" (List [
App "()" (List []),App "Ident" (List [App "()" (List []),String
"plate"])])]),App "Con" (List [App "()" (List []),App "UnQual" (
List [App "()" (List []),App "Ident" (List [App "()" (List []),
CtorName])])])])]]))]),App "Nothing" (List [])]))])])]])])]
-- GENERATED STOP
-- InstDecl SrcLoc (Maybe Overlap) [TyVarBind] Context QName [Type] [InstDecl]
-- InstDecl l (Maybe (Overlap l)) (InstRule l) (Maybe [InstDecl l])
custom x [InstDecl () x2 (IParen () rule) mbDecl] = custom x [InstDecl () x2 rule mbDecl]
custom (_,d) [InstDecl () x2 (IRule () x3 _ ihead) x7] = [InstDecl () x2 (IRule () x3 x4 iheadOut) x7]
where
(_x6, x5) = collect [] ihead
vars = dataDeclVars d
dd = (if null vars then id else TyParen ()) $ tyApps (tyCon $ dataDeclName d) (map tyVar vars)
x4 = Just $ CxTuple () $
concatMap f vars ++ [ClassA () (qname x) [tyVar "to"] | x <- ["Typeable","Uniplate"]]
x6 = [dd, tyVar "to"]
iheadOut = foldr (flip (IHApp ())) (IHCon () x5) x6
f v = [ClassA () (qname "Typeable") [tyVar v], ClassA () (qname "PlateAll") [tyVar v, tyVar "to"]]
collect acc (IHCon () qname) = (acc, qname)
collect acc (IHInfix () arg qname) = (arg:acc, qname)
collect acc (IHParen () ih) = collect acc ih
collect acc (IHApp () ih arg) = collect (arg:acc) ih
derive-2.6.5/src/Data/Derive/Update.hs 0000644 0000000 0000000 00000002714 07346545000 015633 0 ustar 00 0000000 0000000 {-|
A Pseudo derivation. For every label, creates a function
foo_u and foo_s which updates and sets the label respectively,
e.g. 'foo_u (+1) bar' or 'foo_s 10 baz'
-}
module Data.Derive.Update(makeUpdate) where
{-
test :: Computer
speed_u :: (Int -> Int) -> Computer -> Computer
speed_u f x = x{speed = f (speed x)}
speed_s :: Int -> Computer -> Computer
speed_s v x = x{speed = v}
weight_u :: (Double -> Double) -> Computer -> Computer
weight_u f x = x{weight = f (weight x)}
weight_s :: Double -> Computer -> Computer
weight_s v x = x{weight = v}
test :: Sample
-}
import Language.Haskell
import Data.Derive.Internal.Derivation
import Data.Maybe
makeUpdate :: Derivation
makeUpdate = derivationCustom "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d
makeUpdateField :: DataDecl -> String -> [Decl ()]
makeUpdateField d field =
[TypeSig () [name upd] (TyFun () (TyParen () (TyFun () typF typF)) typR)
,bind upd [pVar "f",pVar "x"] $ RecUpdate () (var "x") [FieldUpdate () (qname field) (App () (var "f") (Paren () $ App () (var field) (var "x")))]
,TypeSig () [name set] (TyFun () typF typR)
,bind set [pVar "v",pVar "x"] $ RecUpdate () (var "x") [FieldUpdate () (qname field) (var "v")]]
where
set = field ++ "_s"
upd = field ++ "_u"
typR = TyFun () (dataDeclType d) (dataDeclType d)
typF = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
derive-2.6.5/src/Data/ 0000755 0000000 0000000 00000000000 07346545000 012633 5 ustar 00 0000000 0000000 derive-2.6.5/src/Data/DeriveDSL.hs 0000644 0000000 0000000 00000000720 07346545000 014747 0 ustar 00 0000000 0000000
module Data.DeriveDSL(DSL, deriveDSL, applyDSL, dynamicDSL) where
import Data.Derive.DSL.Derive
import Data.Derive.DSL.Apply
import Data.Derive.DSL.DSL
import Data.Derive.DSL.HSE
import Data.Derive.DSL.SYB
import Data.Maybe
deriveDSL :: [Decl ()] -> Maybe DSL
deriveDSL = listToMaybe . derive
applyDSL :: DSL -> DataDecl -> Either String [Decl ()]
applyDSL dsl inp = Right $ apply dsl $ toInput inp
dynamicDSL :: DSL -> Maybe [Decl ()]
dynamicDSL = dslSYB
derive-2.6.5/src/Data/DeriveMain.hs 0000644 0000000 0000000 00000001025 07346545000 015210 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- Needed for Haddock docs
-- | Use this module to create your own derive program, supporting custom derivations.
-- As an example:
--
-- @
-- import "Data.DeriveMain" ('deriveMain')
-- import "Data.Derive.All" ('derivations')
-- import MyProject.MyDerivation (myDerivation)
-- @
--
-- @
-- main :: IO
-- main = 'deriveMain' $ [myDerivation] ++ 'derivations'
-- @
module Data.DeriveMain(deriveMain) where
import Derive.Main
import Data.Derive.All(derivations)
derive-2.6.5/src/Data/DeriveTH.hs 0000644 0000000 0000000 00000003166 07346545000 014647 0 ustar 00 0000000 0000000 -- | The main TH driver module. It is intended that this need be the
-- only module imported by user code; it takes care of all data
-- threading issues such that all one needs to do is:
--
-- @
-- data Foo = Foo ; $( derive makeEq ''Foo )
-- @
module Data.DeriveTH(derive, derives, deriveFromDec, module Data.Derive.All) where
import Control.Monad
import Data.Derive.All
import Data.Derive.Internal.Derivation
import Language.Haskell.TH.All as TH hiding (Derivation(..),toName)
import Language.Haskell as HS
import Language.Haskell.Convert
-- | Derive an instance of some class. @derive@ only derives instances
-- for the type of the argument.
derive :: Derivation -> TH.Name -> Q [Dec]
derive d name = do
x <- reify name
case x of
TyConI dec -> deriveFromDec d dec
_ -> error $ "Data.DeriveTH.derive: Expected a data type declaration, got:\n" ++ show x
derives :: [Derivation] -> [TH.Name] -> Q [Dec]
derives xs ys = liftM concat $ sequence [derive x y | y <- ys, x <- xs]
-- | Derive an instance of some class. @deriveFromDec@ only derives instances
-- for the type of the argument.
deriveFromDec :: Derivation -> Dec -> Q [Dec]
deriveFromDec d x = do
x <- liftM normData $ expandData x
let unsup x = error $ "Derivation of " ++ derivationName d ++ " does not yet support Template Haskell, requires info for " ++ x
case derivationOp d (tyCon $ derivationName d) unsup $ toFullDataDecl x of
Left y -> runIO (putStrLn $ "Warning, couldn't derive: " ++ y) >> return []
Right v -> return $ convert v
toFullDataDecl :: Dec -> FullDataDecl
toFullDataDecl x = (ModuleName () "Todo", convert x)
derive-2.6.5/src/Derive/ 0000755 0000000 0000000 00000000000 07346545000 013200 5 ustar 00 0000000 0000000 derive-2.6.5/src/Derive/Derivation.hs 0000644 0000000 0000000 00000007736 07346545000 015655 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns #-}
module Derive.Derivation(wantDerive, performDerive, writeDerive) where
import System.IO
import System.IO.Unsafe
import Language.Haskell
import Control.Arrow
import Control.Monad
import Data.List
import Derive.Utils
import Derive.Flags
import Data.Derive.Internal.Derivation
import qualified Data.Map as Map
---------------------------------------------------------------------
-- WHAT DO YOU WANT TO DERIVE
wantDerive :: [Flag] -> Module () -> Module () -> [Type ()]
wantDerive flag real mine = nub $ map fromTyParens $ wantDeriveFlag flag decls ++ wantDeriveAnnotation real mine
where decls = filter isDataDecl $ moduleDecls mine
wantDeriveFlag :: [Flag] -> [DataDecl] -> [Type ()]
wantDeriveFlag flags decls = [TyApp () (tyCon x) d | Derive xs <- flags, x <- xs, d <- declst]
where declst = [tyApps (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d) | d <- decls]
wantDeriveAnnotation :: Module () -> Module () -> [Type ()]
wantDeriveAnnotation real mine = moduleDerives mine \\ moduleDerives real
moduleDerives :: Module () -> [Type ()]
moduleDerives = concatMap f . moduleDecls
where
f (DataDecl _ _ _ (fromDeclHead -> (name, vars)) _ deriv) = g name vars deriv
f (GDataDecl _ _ _ (fromDeclHead -> (name, vars)) _ _ deriv) = g name vars deriv
f (DerivDecl _ _ _ (fromIParen -> IRule _ _ _ (fromInstHead -> (name, args)))) = [TyCon () name `tyApps` args]
f _ = []
g name vars deriv = [TyCon () a `tyApps` (b:bs) | IRule _ _ _ (fromInstHead -> (a,bs)) <- map fromIParen $ f deriv]
where b = TyCon () (UnQual () name) `tyApps` map (tyVar . prettyPrint) vars
f [Deriving _ _ xs] = xs
f _ = []
---------------------------------------------------------------------
-- ACTUALLY DERIVE IT
performDerive :: [Derivation] -> Module () -> [Type ()] -> [String]
performDerive derivations modu = concatMap ((:) "" . f)
where
grab = getDecl modu
g = getDerivation derivations
f ty = case d ty grab (moduleName modu, grab typ1Name) of
Left x -> unsafePerformIO $ let res = msg x in hPutStrLn stderr res >> return ["-- " ++ res]
Right x -> concatMap (lines . prettyPrint) x
where
d = derivationOp $ g clsName
(cls,typ1:_) = fromTyApps ty
clsName = prettyPrint cls
typ1Name = tyRoot typ1
msg x = "Deriving " ++ prettyPrint ty ++ ": " ++ x
getDecl :: Module () -> (String -> Decl ())
getDecl modu = \name -> Map.findWithDefault (error $ "Can't find data type definition for: " ++ name) name mp
where
mp = Map.fromList $ concatMap f $ moduleDecls modu
f x@(DataDecl _ _ _ (fromDeclHead -> (name, _)) _ _) = [(prettyPrint name, x)]
f x@(GDataDecl _ _ _ (fromDeclHead -> (name, _)) _ _ _) = [(prettyPrint name, x)]
f x@(TypeDecl _ (fromDeclHead -> (name, _)) _) = [(prettyPrint name, x)]
f _ = []
getDerivation :: [Derivation] -> String -> Derivation
getDerivation derivations = \name -> Map.findWithDefault (error $ "Don't know how to derive type class: " ++ name) name mp
where
mp = Map.fromList $ map (derivationName &&& id) derivations
---------------------------------------------------------------------
-- WRITE IT BACK
writeDerive :: FilePath -> ModuleName () -> [Flag] -> [String] -> IO ()
writeDerive file modu flags xs = do
-- force the output first, ensure that we don't crash half way through
() <- length (concat xs) `seq` return ()
let append = Append `elem` flags
let output = [x | Output x <- flags]
let ans = take 1 ["module " ++ x ++ " where" | Modu x <- reverse flags] ++
["import " ++ if null i then prettyPrint modu else i | Import i <- flags] ++
xs
when append $ do
src <- readFile' file
writeGenerated file ans
forM output $ \o -> writeFile o $ unlines ans
when (not append && null output) $ putStr $ unlines ans
derive-2.6.5/src/Derive/Flags.hs 0000644 0000000 0000000 00000005040 07346545000 014567 0 ustar 00 0000000 0000000
module Derive.Flags(Flag(..), getFlags, addFlags, flagInfo) where
import System.Environment
import System.Console.GetOpt
import System.Directory
import Language.Haskell
import System.Exit
import System.IO
import Data.Maybe
data Flag = Version | Help | Output String | Import String | Modu String
| Append | Derive [String] | NoOpts | Preprocessor | Test | Generate
deriving (Eq, Show)
options :: [OptDescr Flag]
options =
[Option "v" ["version"] (NoArg Version) "show version number"
,Option "h?" ["help"] (NoArg Help) "show help message"
,Option "o" ["output"] (ReqArg Output "FILE") "output FILE"
,Option "i" ["import"] (OptArg (Import . fromMaybe "") "MODULE") "add an import statement"
,Option "m" ["module"] (ReqArg Modu "MODULE") "add a module MODULE where statement"
,Option "a" ["append"] (NoArg Append) "append the result to the file"
,Option "d" ["derive"] (ReqArg splt "DERIVES") "things to derive for all types"
,Option "n" ["no-opts"] (NoArg NoOpts) "ignore the file options"
,Option "F" ["preprocessor"] (NoArg Preprocessor) "operate as a GHC preprocessor with -pgmF"
,Option "" ["test"] (NoArg Test) "run the test suite"
,Option "" ["generate"] (NoArg Generate) "perform code generation"
]
where splt = Derive . words . map (\x -> if x == ',' then ' ' else x)
flagInfo = usageInfo "Usage: derive [OPTION...] files..." options
getFlags :: IO ([Flag], [String])
getFlags = do
args <- getArgs
case getOpt Permute options args of
(o,n,[] ) | Version `elem` o -> putStrLn "Derive 2.5.* (C) Neil Mitchell 2006-2013" >> exitSuccess
| Help `elem` o -> putStr flagInfo >> exitSuccess
| Preprocessor `elem` o -> return (o,n)
| otherwise -> do files <- mapM pickFile n; return (o, files)
(_,_,errs) -> hPutStr stderr (concat errs ++ flagInfo) >> exitFailure
where
exitSuccess = exitWith ExitSuccess
pickFile :: FilePath -> IO FilePath
pickFile orig = f [orig, orig ++ ".hs", orig ++ ".lhs"]
where
f [] = error $ "File not found: " ++ orig
f (x:xs) = do
b <- doesFileExist x
if b then return x else f xs
addFlags :: [Flag] -> (SrcLoc, [String]) -> [Flag]
addFlags flags (sl,xs)
| NoOpts `elem` flags = flags
| errs /= [] = error $ prettyPrint sl ++ "\n" ++ concat errs
| otherwise = flags ++ a
where (a,_,errs) = getOpt Permute options xs
derive-2.6.5/src/Derive/Generate.hs 0000644 0000000 0000000 00000010626 07346545000 015273 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 ++ ["","