derive-2.5.23/ 0000755 0000000 0000000 00000000000 12623341654 011255 5 ustar 00 0000000 0000000 derive-2.5.23/Setup.hs 0000644 0000000 0000000 00000000056 12623341654 012712 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
derive-2.5.23/README.md 0000644 0000000 0000000 00000030665 12623341654 012546 0 ustar 00 0000000 0000000 # Derive [](https://hackage.haskell.org/package/derive) [](https://travis-ci.org/ndmitchell/derive)
Data.Derive is a library and a tool for deriving instances for Haskell programs. It is designed to work with custom derivations, SYB and Template Haskell mechanisms. The tool requires GHC, but the generated code is portable to all compilers. We see this tool as a competitor to DrIFT.
This document proceeds as follows:
* Obtaining and Installing Data.Derive
* Supported Derivations
* Using the Derive Program
* Using Template Haskell Derivations
* Writing a New Derivation
### Acknowledgements
Thanks to everyone who has submitted patches and given assistance, including: Twan van Laarhoven, Spencer Janssen, Andrea Vezzosi, Samuel Bronson, Joel Raymont, Benedikt Huber, Stefan O'Rear, Robin Green, Bertram Felgenhauer.
## Obtaining and Installing Data.Derive
Installation follows the standard pattern of any Haskell library or program, type cabal update to update your local hackage database, then cabal install derive to install Derive.
## Supported Derivations
Data.Derive is not limited to any prebuild set of derivations, see later for howto add your own. Out of the box, we provide instances for the following libraries.
* **[Arbitrary](http://hackage.haskell.org/packages/archive/QuickCheck/latest/doc/html/Test-QuickCheck.html#t%3AArbitrary)** - from the library [QuickCheck](http://hackage.haskell.org/package/QuickCheck)
* **[ArbitraryOld](http://hackage.haskell.org/packages/archive/QuickCheck/1.2.0.0/doc/html/Test-QuickCheck.html#t%3AArbitraryOld)** - from the library [QuickCheck-1.2.0.0](http://hackage.haskell.org/package/QuickCheck-1.2.0.0)
* **[Arities](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Class-Arities.html#t%3AArities)** - from the library [derive](http://hackage.haskell.org/package/derive)
* **[Binary](http://hackage.haskell.org/packages/archive/binary/latest/doc/html/Data-Binary.html#t%3ABinary)** - from the library [binary](http://hackage.haskell.org/package/binary)
* **[BinaryDefer](http://hackage.haskell.org/packages/archive/binarydefer/latest/doc/html/Data-Binary-Defer.html#t%3ABinaryDefer)** - from the library [binarydefer](http://hackage.haskell.org/package/binarydefer)
* **[Bounded](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ABounded)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Data](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Data.html#t%3AData)** - from the library [base](http://hackage.haskell.org/package/base)
* **[DataAbstract](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Data.html#t%3ADataAbstract)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Default](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Class-Default.html#t%3ADefault)** - from the library [derive](http://hackage.haskell.org/package/derive)
* **[Enum](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEnum)** - from the library [base](http://hackage.haskell.org/package/base)
* **[EnumCyclic](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEnum)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Eq](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEq)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Fold](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Fold.html)**
* **[Foldable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Foldable.html#t%3AFoldable)** - from the library [base](http://hackage.haskell.org/package/base)
* **[From](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-From.html)**
* **[Functor](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AFunctor)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Has](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Has.html)**
* **[Is](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Is.html)**
* **[JSON](http://hackage.haskell.org/packages/archive/json/latest/doc/html/Text-JSON.html#t%3AJSON)** - from the library [json](http://hackage.haskell.org/package/json)
* **[LazySet](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-LazySet.html)**
* **[Lens](http://hackage.haskell.org/packages/archive/data/lens/doc/html/Data-Lens-Common.html#t%3ALens)** - from the library [data-lens](http://hackage.haskell.org/package/data-lens)
* **[Monoid](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Monoid.html#t%3AMonoid)** - from the library [base](http://hackage.haskell.org/package/base)
* **[NFData](http://hackage.haskell.org/packages/archive/deepseq/latest/doc/html/Control-DeepSeq.html#t%3ANFData)** - from the library [deepseq](http://hackage.haskell.org/package/deepseq)
* **[Ord](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AOrd)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Read](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ARead)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Ref](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Ref.html)**
* **[Serial](http://hackage.haskell.org/packages/archive/smallcheck/latest/doc/html/Test-SmallCheck.html#t%3ASerial)** - from the library [smallcheck](http://hackage.haskell.org/package/smallcheck)
* **[Serialize](http://hackage.haskell.org/packages/archive/cereal/latest/doc/html/Data-Serialize.html#t%3ASerialize)** - from the library [cereal](http://hackage.haskell.org/package/cereal)
* **[Set](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Set.html)**
* **[Show](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AShow)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Traversable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Traversable.html#t%3ATraversable)** - from the library [base](http://hackage.haskell.org/package/base)
* **[Typeable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Typeable.html#t%3ATypeable)** - from the library [base](http://hackage.haskell.org/package/base)
* **[UniplateDirect](http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-Uniplate-Direct.html#t%3AUniplateDirect)** - from the library [uniplate](http://hackage.haskell.org/package/uniplate)
* **[UniplateTypeable](http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-Uniplate-Typeable.html#t%3AUniplateTypeable)** - from the library [uniplate](http://hackage.haskell.org/package/uniplate)
* **[Update](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Update.html)**
## Using the Derive program
Let's imagine we've defined a data type:
data Color = RGB Int Int Int
| CMYK Int Int Int Int
deriving (Eq, Show)
Now we wish to extend this to derive Binary and change to defining Eq using our library. To do this we simply add to the deriving clause.
data Color = RGB Int Int Int
| CMYK Int Int Int Int
deriving (Show {-! Eq, Binary !-})
Or alternatively write:
{-!
deriving instance Eq Color
deriving instance Binary Color
!-}
Now running derive on the program containing this code will generate appropriate instances. How do you combine these instances back into the code? There are various mechanisms supported.
### Appending to the module
One way is to append the text to the bottom of the module, this can be done by passing the --append flag. If this is done, Derive will generate the required instances and place them at the bottom of the file, along with a checksum. Do not modify these instances.
### As a GHC preprocessor
To use Derive as a GHC preprocessor, add the following line at the top of the source file:
{-# OPTIONS_GHC -F -pgmFderive -optF-F #-}
This instructs GHC to apply a preprocessor (-F), and to use the preprocessor derive -F.
### Using CPP
One way is to use CPP. Ensure your compiler is set up for compiling with the C Pre Processor. For example:
{-# LANGUAGE CPP #-}
{-# OPTIONS_DERIVE --output=file.h #-}
module ModuleName where
#include "file.h"
### Side-by-side Modules
If you had Colour.Type, and wished to place the Binary instance in Colour.Binary, this can be done with:
{-# OPTIONS_DERIVE --output=Binary.hs --module=Colour.Binary --import #-}
Here you ask for the output to go to a particular file, give a specific module name and import this module. This will only work if the data structure is exported non-abstractly.
## Using Template Haskell Derivations
One of Derive's advantages over DrIFT is support for Template Haskell (abbreviated TH). Derive can be invoked automatically during the compilation process, and transparently supports deriving across module boundaries. The main disadvantage of TH-based deriving is that it is only portable to compilers that support TH; currently that is GHC only.
To use the TH deriving system, with the same example as before:
{-# LANGUAGE TemplateHaskell #-}
import Data.DeriveTH
import Data.Binary
data Color = RGB Int Int Int
| CMYK Int Int Int Int
deriving (Show)
$( derive makeEq ''Color )
$( derive makeBinary ''Color )
We need to tell the compiler to insert the instance using the TH splice construct, $( ... ) (the spaces are optional). The splice causes the compiler to run the function derive (exported from Data.DeriveTH), passing arguments makeFooBar and ''Color. The second argument deserves more explanation; it is a quoted symbol, somewhat like a quoted symbol in Lisp and with deliberately similar syntax. (Two apostrophes are used to specify that this name is to be resolved as a type constructor; just 'Color would look for a data constructor named Color.)
## Writing a New Derivation
There are two methods for writing a new derivation, guessing or coding. The guessing method is substantially easier if it will work for you, but is limited to derivations with the following properties:
* Inductive - each derivation must be similar to the previous one. Binary does not have this property as a 1 item derivation does not have a tag, but a 2 item derivation does.
* Not inductive on the type - it must be an instance for the constructors, not for the type. Typeable violates this property by inducting on the free variables in the data type.
* Not type based - the derivation must not change based on the types of the fields. Play and Functor both behave differently given differently typed fields.
* Not record based - the derivation must not change on record fields. Show outputs the fields, so this is not allowed.
If however your instance does meet these properties, you can use derivation by guess. Many instances do meet these conditions, for examples see: Eq, Ord, Data, Serial etc. If however you need to code the derivation manually see examples such as Update and Functor.
### Modifying Derive
The standard sequence for testing Derive is:
$ ghci Main.hs
:main --generate
:reload
:main --test
The `--generate` option will automatically generate DSL's for derivations derived by example. The `--test` option runs all test comparisons and then loads the file with Template Haskell.
### Coding a new derivation
My best suggestion, start with a similar instance, i.e. to make `Eq2` from `Eq` do:
* Copy `Data/Derive/Eq.hs` to `Data/Derive/Eq2.hs`
* Rename some of the bits in `Eq2.hs` from `Eq`
* `ghci` -- load derive
* `:main` --generate -- this adds Eq2.hs to the .cabal/All.hs files etc
* `:reload` -- reload with Eq2.hs
Now fix up `Eq2.hs` appropriately.
derive-2.5.23/Main.hs 0000644 0000000 0000000 00000000166 12623341654 012500 0 ustar 00 0000000 0000000
module Main(main) where
import Data.Derive.All
import Data.DeriveMain
main :: IO ()
main = deriveMain derivations
derive-2.5.23/LICENSE 0000644 0000000 0000000 00000002764 12623341654 012273 0 ustar 00 0000000 0000000 Copyright Neil Mitchell 2006-2015.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Neil Mitchell nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
derive-2.5.23/derive.cabal 0000644 0000000 0000000 00000006474 12623341654 013532 0 ustar 00 0000000 0000000 cabal-version: >= 1.6
build-type: Default
name: derive
version: 2.5.23
build-type: Simple
copyright: Neil Mitchell 2006-2015
author: Neil Mitchell
maintainer: Neil Mitchell
homepage: https://github.com/ndmitchell/derive#readme
bug-reports: https://github.com/ndmitchell/derive/issues
license: BSD3
license-file: LICENSE
synopsis: A program and library to derive instances for data types
category: Development
description:
Data.Derive is a library and a tool for deriving instances for Haskell programs.
It is designed to work with custom derivations, SYB and Template Haskell mechanisms.
The tool requires GHC, but the generated code is portable to all compilers.
We see this tool as a competitor to DrIFT.
extra-doc-files:
README.md
CHANGES.txt
tested-with: GHC==7.10.1, GHC==7.8.4, GHC==7.6.3
source-repository head
type: git
location: https://github.com/ndmitchell/derive.git
executable derive
main-is: Main.hs
library
build-depends:
base == 4.*,
filepath, syb, template-haskell, containers, pretty,
directory, process, bytestring,
haskell-src-exts >= 1.17 && < 1.18,
transformers >= 0.2,
uniplate >= 1.5 && < 1.7
exposed-modules:
Data.DeriveMain
Data.DeriveTH
Data.DeriveDSL
Data.Derive.All
Data.Derive.DSL.Apply
Data.Derive.DSL.Derive
Data.Derive.DSL.DSL
Data.Derive.DSL.HSE
Data.Derive.DSL.SYB
Data.Derive.Instance.Arities
Data.Derive.Class.Arities
Data.Derive.Class.Default
Language.Haskell
Language.Haskell.Convert
Language.Haskell.TH.All
Language.Haskell.TH.Compat
Language.Haskell.TH.Data
Language.Haskell.TH.ExpandSynonym
Language.Haskell.TH.FixedPpr
Language.Haskell.TH.Helper
Language.Haskell.TH.Peephole
-- GENERATED START
Data.Derive.Arbitrary
Data.Derive.ArbitraryOld
Data.Derive.Arities
Data.Derive.Binary
Data.Derive.BinaryDefer
Data.Derive.Bounded
Data.Derive.Data
Data.Derive.DataAbstract
Data.Derive.Default
Data.Derive.Enum
Data.Derive.EnumCyclic
Data.Derive.Eq
Data.Derive.Fold
Data.Derive.Foldable
Data.Derive.From
Data.Derive.Functor
Data.Derive.Has
Data.Derive.Is
Data.Derive.JSON
Data.Derive.LazySet
Data.Derive.Lens
Data.Derive.Monoid
Data.Derive.NFData
Data.Derive.Ord
Data.Derive.Read
Data.Derive.Ref
Data.Derive.Serial
Data.Derive.Serialize
Data.Derive.Set
Data.Derive.Show
Data.Derive.Traversable
Data.Derive.Typeable
Data.Derive.UniplateDirect
Data.Derive.UniplateTypeable
Data.Derive.Update
-- GENERATED STOP
-- Mainly internal but some still people use them
-- to implement derivations outside
Data.Derive.Internal.Derivation
other-modules:
Data.Derive.Internal.Instance
Data.Derive.Internal.Traversal
Derive.Main
Derive.Derivation
Derive.Flags
Derive.Generate
Derive.Test
Derive.Utils
derive-2.5.23/CHANGES.txt 0000644 0000000 0000000 00000002621 12623341654 013067 0 ustar 00 0000000 0000000 Changelog for Derive
2.5.23
Require haskell-src-exts-1.17
2.5.22
#7, #8 convert more types from TemplateHaskell
2.5.21
Fix the homepage link
2.5.20
#5, fix regression with higher-kinded constructors becoming context
2.5.19
Support GHC 7.10
2.5.18
#4, fix the read instance for nullary constructors
2.5.17
Upgrade to haskell-src-exts-1.16
Remove GHC 7.2 support
2.5.16
Allow transformers-0.4 and above
2.5.15
Allow haskell-src-exts-1.15.*
2.5.14
#3, support GHC 7.9
2.5.13
#622, turn on more Haskell extensions
2.5.12
Upgrade to haskell-src-exts-1.14.*
2.5.11
Support GHC 7.6
2.5.10
Add derivation for Lens
Modify the Typeable derivation to use mkTyCon3
2.5.9
Support the Template Haskell Unpacked constructor
2.5.8
Allow haskell-src-exts-1.13.*
2.5.7
Allow haskell-src-exts-1.12.*
2.5.6
Update the copyright year
Allow transformers-0.3.*
2.5.5
#513, allow derive to be run as a preprocessor
Improve the documentation for UniplateDirect
2.5.4
#394, allow tuple names in more places
Fix error when deriving Binary on "data A = B"
2.5.3
GHC 7.2 compatibility
2.5.2
Relax the dependency on haskell-src-exts to < 1.12
2.5.1
Improve documentation for deriveMain
2.5
#257, add Data.DeriveMain.deriveMain, to allow user derivations
2.4.2
Relax the dependency on haskell-src-exts to < 1.11
Start of changelog
derive-2.5.23/Language/ 0000755 0000000 0000000 00000000000 12623341654 013000 5 ustar 00 0000000 0000000 derive-2.5.23/Language/Haskell.hs 0000644 0000000 0000000 00000024345 12623341654 014727 0 ustar 00 0000000 0000000
module Language.Haskell(module Language.Haskell, module Language.Haskell.Exts) where
import Language.Haskell.Exts hiding (var,app,binds,paren)
import Data.List
import Data.Generics.Uniplate.Data
import Data.Data
import Data.Char
import Data.Maybe
infix 1 ?
True ? b = const b
False ? b = id
-- insert explicit foralls
foralls :: Type -> Type
foralls x = TyForall (Just $ map UnkindedVar $ nub [y | TyVar y <- universe x]) [] x
tyApps x [] = x
tyApps x (y:ys) = tyApps (TyApp x y) ys
fromTyApps (TyTuple _ xs) = (tyCon $ "(" ++ replicate (length xs - 1) ',' ++ ")", xs)
fromTyApps (TyApp x y) = let (a,b) = fromTyApps x in (a, b ++ [y])
fromTyApps (TyList x) = (TyCon $ Special ListCon, [x])
fromTyApps x = (x, [])
fromTyTuple (TyTuple _ xs) = xs
fromTyTuple x = [x]
fromTyParen (TyParen x) = fromTyParen x
fromTyParen x = x
fromTyParens = transform fromTyParen
tyRoot = prettyPrint . fst . fromTyApps . fromTyParen
isTyFun TyFun{} = True
isTyFun _ = False
isTyParen TyParen{} = True ; isTyParen _ = False
fromTyList (TyList x) = Just x
fromTyList (TyApp (TyCon (Special ListCon)) x) = Just x
fromTyList x = Nothing
x ~= y = prettyPrint x == y
appP x@App{} y = App x y
appP x y = App (paren x) (paren y)
simplify :: Data a => a -> a
simplify = transformBi fDecl . transformBi fMatch . transformBi fPat . transformBi fTyp . transformBi fExp
where
fExp (App op (List xs))
| op ~= "length" = Lit $ Int $ fromIntegral $ length xs
| op ~= "head" = head xs
| op ~= "null" = con $ show $ null xs
fExp (InfixApp (Lit (Int i)) op (Lit (Int j)))
| op ~= "-" = Lit $ Int $ i - j
| op ~= "+" = Lit $ Int $ i + j
| op ~= ">" = Con $ UnQual $ Ident $ show $ i > j
fExp (InfixApp x op y)
| op ~= "`const`" = x
| op ~= "&&" && y ~= "True" = x
| x ~= "id" && op ~= "." = y
| y ~= "id" && op ~= "." = x
fExp (InfixApp (Lit (String x)) op (Lit (String y))) | op ~= "++" = Lit $ String $ x ++ y
fExp (App (App (App flp f) x) y) | flp ~= "flip" = fExp $ appP (fExp $ appP f y) x
fExp (App (Paren x@App{}) y) = fExp $ App x y
fExp (App (Paren (InfixApp x op y)) z) | op ~= "." = fExp $ appP x $ fExp $ appP y z
fExp (App op x) | op ~= "id" = x
fExp (App (App flp con) x) | flp ~= "flip" && con ~= "const" = var "id"
fExp (App (App con x) y) | con ~= "const" = x
fExp (App choose (Tuple _ [x@(ExpTypeSig _ y _),z])) | choose ~= "choose" && y == z = fExp $ App (var "return") x
fExp (App op x) | op ~= "id" = x
fExp (InfixApp (App when true) dot res)
| when ~= "when" && true ~= "True" = res
fExp (InfixApp x y z) | y ~= "++" && z ~= "[]" = x
fExp (App (LeftSection x op) y) = fExp $ InfixApp x op (paren y)
fExp (Paren x) | isAtom x = x
fExp (Do [Qualifier x]) = x
fExp (Do (Qualifier (App ret unit):xs)) | ret ~= "return" && unit ~= "()" = fExp $ Do xs
fExp (Do (Generator _ (PVar x) (App ret y):xs)) | ret ~= "return" && once x2 xs = simplify $ Do $ subst x2 y xs
where x2 = Var $ UnQual x
fExp (Case (ExpTypeSig _ x@Lit{} _) alts) = fExp $ Case x alts
fExp (Case (Lit x) alts) | good /= [] = head good
where good = [z | Alt _ (PLit Signless y) (UnGuardedRhs z) Nothing <- alts, y == x]
fExp (If x t f)
| x ~= "True" = t
| x ~= "False" = f
fExp (App (App when b) x)
| when ~= "when" && b ~= "True" = x
| when ~= "when" && b ~= "False" = App (Var $ UnQual $ Ident "return") (Con $ Special $ TupleCon Boxed 0)
fExp (App (Paren (Lambda _ [PVar x] y)) z) | once x2 y = fExp $ subst x2 z y
where x2 = Var $ UnQual x
fExp (App (Paren (Lambda _ [PWildCard] x)) _) = x
fExp (Lambda s ps x) = Lambda s (minPat x ps) x
fExp (Con x) = Con $ rename x
fExp x = x
fTyp (TyApp x y) | x ~= "[]" = TyList y
fTyp (TyApp (TyCon (Special ListCon)) x) = TyList x
fTyp (TyParen x@TyCon{}) = x
fTyp (TyParen x@TyVar{}) = x
fTyp (TyParen x@TyList{}) = x
fTyp (TyCon nam) = TyCon $ rename nam
fTyp x = x
fPat (PParen x@(PApp _ [])) = x
fPat (PParen (PParen x)) = PParen x
fPat (PApp nam xs) = case rename nam of
Special (TupleCon Boxed _) -> PTuple Boxed xs
nam -> PApp nam xs
fPat (PParen (PTuple l xs)) = PTuple l xs
fPat x = x
fMatch (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls)
| x ~= "True" = fMatch $ Match sl nam pat sig (UnGuardedRhs bod) decls
fMatch (Match sl nam [PVar x] sig (UnGuardedRhs (Case (Var (UnQual x2)) [Alt _ pat (UnGuardedRhs y) Nothing])) decls)
| x == x2 = fMatch $ Match sl nam [PParen pat] sig (UnGuardedRhs y) decls
fMatch o@(Match a b c d e bind) = fBinds (Match a b (minPat o c) d e) bind
fDecl (PatBind a b c bind) = fBinds (PatBind a b c) bind
fDecl (FunBind xs) = FunBind $ filter (not . isGuardFalse) xs
fDecl x = x
fBinds context Nothing = context Nothing
fBinds context (Just (BDecls bind)) | inline /= [] =
simplify $ subst (Var $ UnQual from) to $ context $
let xs = take i bind ++ drop (i+1) bind in if null xs then Nothing else Just $ BDecls xs
where
f (PatBind _ (PVar x) (UnGuardedRhs bod) Nothing) = [(x,bod)]
f (FunBind [Match _ x [PVar v] Nothing (UnGuardedRhs (Paren (App bod (Var v2)))) Nothing])
| UnQual v == v2 = [(x,bod)]
f (FunBind [Match sl x pat Nothing (UnGuardedRhs bod) Nothing]) = [(x,Paren $ Lambda sl pat bod)]
f _ = []
(i,from,to) = head inline
inline = [(i, x, bod)
| (i,b) <- zip [0..] bind, (x,bod) <- f b
, isAtom bod || once (Var $ UnQual x) (context $ Just $ BDecls bind)]
fBinds a y = a y
subst from to = transformBi $ \x -> if x == from then to else x
once x y = length (filter (== x) (universeBi y)) <= 1
minPat o ps = transformBi f ps
where
known = nub [x | UnQual x <- universeBi o]
f (PVar x) | x `notElem` known = PWildCard
f (PAsPat x y) | x `notElem` known = y
f x = x
isGuardFalse (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls) = x ~= "False"
isGuardFalse _ = False
rename (UnQual (Ident ('(':xs@(x:_))))
| x == ',' = Special $ TupleCon Boxed $ length xs
| x /= ')' = UnQual $ Symbol $ init xs
rename x = x
isAtom Con{} = True
isAtom Var{} = True
isAtom Lit{} = True
isAtom Paren{} = True
isAtom _ = False
paren x = if isAtom x then x else Paren x
sl = SrcLoc "" 0 0
noSl mr = transformBi (const sl) mr
isIdent (x:xs) = isAlpha x || x == '_'
title (x:xs) = toUpper x : xs
qname = UnQual . name
var = Var . qname
con = Con . qname
tyVar = TyVar . name
tyVarBind = UnkindedVar . name
tyCon = TyCon . qname
pVar = PVar . name
qvop = QVarOp . UnQual . Symbol
dataDeclType :: DataDecl -> Type
dataDeclType d = tyApp (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d)
dataDeclFields :: DataDecl -> [String]
dataDeclFields = sort . nub . filter (not . null) . map fst . concatMap ctorDeclFields . dataDeclCtors
-- A declaration that is either a DataDecl of GDataDecl
type DataDecl = Decl
type CtorDecl = Either QualConDecl GadtDecl
type FieldDecl = [(String, Type)]
type FullDataDecl = (ModuleName, DataDecl)
moduleName (Module _ name _ _ _ _ _) = name
moduleDecls (Module _ _ _ _ _ _ decls) = decls
moduleImports (Module _ _ _ _ _ imps _) = imps
modulePragmas (Module _ _ pragmas _ _ _ _) = pragmas
showDecls x = unlines $ map prettyPrint x
tyApp x [] = x
tyApp x xs = TyApp (tyApp x $ init xs) (last xs)
tyFun [x] = x
tyFun (x:xs) = TyFun x (tyFun xs)
apps x [] = x
apps x (y:ys) = apps (App x y) ys
bind :: String -> [Pat] -> Exp -> Decl
bind s p e = binds s [(p,e)]
binds :: String -> [([Pat], Exp)] -> Decl
binds n [([],e)] = PatBind sl (pVar n) (UnGuardedRhs e) Nothing
binds n xs = FunBind [Match sl (name n) p Nothing (UnGuardedRhs e) Nothing | (p,e) <- xs]
isDataDecl :: Decl -> Bool
isDataDecl DataDecl{} = True
isDataDecl GDataDecl{} = True
isDataDecl _ = False
dataDeclSrcLoc :: DataDecl -> SrcLoc
dataDeclSrcLoc (DataDecl sl _ _ _ _ _ _) = sl
dataDeclSrcLoc (GDataDecl sl _ _ _ _ _ _ _) = sl
dataDeclContext :: DataDecl -> Context
dataDeclContext (DataDecl _ _ ctx _ _ _ _) = ctx
dataDeclContext _ = error "dataDeclContext: not a DataDecl"
dataDeclName :: DataDecl -> String
dataDeclName (DataDecl _ _ _ name _ _ _) = prettyPrint name
dataDeclName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name
dataDeclVars :: DataDecl -> [String]
dataDeclVars (DataDecl _ _ _ _ vars _ _) = map f vars
where f (KindedVar x _) = prettyPrint x
f (UnkindedVar x) = prettyPrint x
dataDeclVarsStar :: DataDecl -> [String]
dataDeclVarsStar (DataDecl _ _ _ _ vars _ _) = mapMaybe f vars
where f (UnkindedVar x) = Just $ prettyPrint x
f (KindedVar x KindStar) = Just $ prettyPrint x
f _ = Nothing
dataDeclArity :: DataDecl -> Int
dataDeclArity = length . dataDeclVars
dataDeclCtors :: DataDecl -> [CtorDecl]
dataDeclCtors (DataDecl _ _ _ _ _ ctors _) = map Left ctors
ctorDeclName :: CtorDecl -> String
ctorDeclName = prettyPrint . ctorDeclName'
ctorDeclName' :: CtorDecl -> Name
ctorDeclName' (Left (QualConDecl _ _ _ (ConDecl name _))) = name
ctorDeclName' (Left (QualConDecl _ _ _ (InfixConDecl _ name _))) = name
ctorDeclName' (Left (QualConDecl _ _ _ (RecDecl name _))) = name
ctorDeclFields :: CtorDecl -> FieldDecl
ctorDeclFields (Left (QualConDecl _ _ _ (ConDecl name fields))) = map ((,) "") fields
ctorDeclFields (Left (QualConDecl _ _ _ (InfixConDecl x1 name x2))) = map ((,) "") [x1,x2]
ctorDeclFields (Left (QualConDecl _ _ _ (RecDecl name fields))) = [(prettyPrint a, b) | (as,b) <- fields, a <- as]
ctorDeclArity :: CtorDecl -> Int
ctorDeclArity = length . ctorDeclFields
declName :: Decl -> String
declName (DataDecl _ _ _ name _ _ _) = prettyPrint name
declName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name
declName (TypeDecl _ name _ _) = prettyPrint name
derive-2.5.23/Language/Haskell/ 0000755 0000000 0000000 00000000000 12623341654 014363 5 ustar 00 0000000 0000000 derive-2.5.23/Language/Haskell/Convert.hs 0000644 0000000 0000000 00000022606 12623341654 016345 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
module Language.Haskell.Convert(Convert, convert) where
import Language.Haskell as HS
import Language.Haskell.TH.Syntax as TH
import Control.Exception
import Data.Typeable
import System.IO.Unsafe
import Data.Maybe
class (Typeable a, Typeable b, Show a, Show b) => Convert a b where
conv :: a -> b
convert :: forall a b . Convert a b => a -> b
convert a = unsafePerformIO $
(return $! (conv a :: b)) `Control.Exception.catch` (\(e :: SomeException) -> error $ msg e)
where
msg e = "Could not convert " ++ show (typeOf a) ++ " to " ++
show (typeOf (undefined :: b)) ++ "\n" ++ show a ++
"\n" ++ show e
appT :: TH.Type -> [TH.Type] -> TH.Type
appT = foldl AppT
c mr = convert mr
instance Convert a b => Convert [a] [b] where
conv = map c
instance Convert TH.Dec HS.Decl where
conv x = case x of
DataD cxt n vs con ds -> f DataType cxt n vs con ds
NewtypeD cxt n vs con ds -> f NewType cxt n vs [con] ds
where
f :: DataOrNew -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> [TH.Name] -> HS.Decl
f t cxt n vs con ds = DataDecl sl t (c cxt) (c n) (c vs) (c con) []
instance Convert TH.Name HS.TyVarBind where
conv = UnkindedVar . c
instance Convert TH.Name HS.Name where
conv x = name $ if '.' `elem` x2 then reverse $ takeWhile (/= '.') $ reverse x2 else x2
where x2 = show x
instance Convert TH.Name HS.QName where
conv x = if x2 == Ident "[]" then Special ListCon else UnQual x2
where x2 = c x
instance Convert TH.Con HS.QualConDecl where
conv (ForallC vs cxt x) = QualConDecl sl (c vs) (c cxt) (c x)
conv x = QualConDecl sl [] [] (c x)
instance Convert TH.Con HS.ConDecl where
conv (NormalC n xs) = ConDecl (c n) (c xs)
conv (RecC n xs) = RecDecl (c n) [([c x], c (y,z)) | (x,y,z) <- xs]
conv (InfixC x n y) = InfixConDecl (c x) (c n) (c y)
instance Convert TH.StrictType HS.Type where
conv (IsStrict, x) = TyBang BangedTy $ c x
conv (NotStrict, x) = c x
#if __GLASGOW_HASKELL__ >= 704
conv (Unpacked, x) = TyBang UnpackedTy $ c x
#endif
instance Convert TH.Type HS.Type where
conv (ForallT xs cxt t) = TyForall (Just $ c xs) (c cxt) (c t)
conv (VarT x) = TyVar $ c x
conv (ConT x) | ',' `elem` show x = TyTuple Boxed []
| otherwise = TyCon $ c x
conv (AppT (AppT ArrowT x) y) = TyFun (c x) (c y)
conv (ArrowT) = TyCon $ Special FunCon
conv (AppT ListT x) = TyList $ c x
conv (ListT) = TyCon $ Special ListCon
conv (TupleT _) = TyTuple Boxed []
conv (AppT x y) = case c x of
TyTuple b xs -> TyTuple b $ xs ++ [c y]
x -> TyApp x $ c y
instance Convert TH.Type HS.Asst where
conv (ConT x) = ClassA (UnQual $ c x) []
conv (AppT x y) = case c x of
ClassA a b -> ClassA a (b ++ [c y])
instance Convert HS.Decl TH.Dec where
conv (InstDecl _ _ _ cxt nam typ ds) = InstanceD (c cxt) (c $ tyApp (TyCon nam) typ) [c d | InsDecl d <- ds]
conv (FunBind ms@(HS.Match _ nam _ _ _ _:_)) = FunD (c nam) (c ms)
conv (PatBind _ p bod ds) = ValD (c p) (c bod) (c ds)
conv (TypeSig _ [nam] typ) = SigD (c nam) (c $ foralls typ)
conv (DataDecl _ DataType ctx nam typ cs ds) =
DataD (c ctx) (c nam) (c typ) (c cs) (c (map fst ds))
conv (DataDecl _ NewType ctx nam typ [con] ds) =
NewtypeD (c ctx) (c nam) (c typ) (c con) (c (map fst ds))
instance Convert HS.QualConDecl TH.Con where
conv (QualConDecl _ [] [] con) = c con
conv (QualConDecl _ vs cx con) = ForallC (c vs) (c cx) (c con)
instance Convert HS.ConDecl TH.Con where
conv (ConDecl nam typ) = NormalC (c nam) (c typ)
conv (InfixConDecl l nam r) = InfixC (c l) (c nam) (c r)
conv (RecDecl nam fs) = RecC (c nam) (concatMap c fs)
instance Convert HS.Type TH.StrictType where
conv (TyBang BangedTy t) = (IsStrict, c t)
#if __GLASGOW_HASKELL__ >= 704
conv (TyBang UnpackedTy t) = (Unpacked, c t)
#else
conv (TyBang UnpackedTy t) = (IsStrict, c t)
#endif
conv t = (NotStrict, c t)
instance Convert ([HS.Name],HS.Type) [TH.VarStrictType] where
conv (names,bt) = [(c name,s,t) | name <- names]
where (s,t) = c bt
instance Convert HS.Asst TH.Type where
conv (InfixA x y z) = c $ ClassA y [x,z]
conv (ClassA x y) = appT (ConT $ c x) (c y)
instance Convert HS.Type TH.Type where
conv (TyCon (Special ListCon)) = ListT
conv (TyCon (Special UnitCon)) = TupleT 0
conv (TyParen x) = c x
conv (TyForall x y z) = ForallT (c $ fromMaybe [] x) (c y) (c z)
conv (TyVar x) = VarT $ c x
conv (TyCon x) = if x ~= "[]" then error "here" else ConT $ c x
conv (TyFun x y) = AppT (AppT ArrowT (c x)) (c y)
conv (TyList x) = AppT ListT (c x)
conv (TyTuple _ x) = appT (TupleT (length x)) (c x)
conv (TyApp x y) = AppT (c x) (c y)
instance Convert HS.Name TH.Name where
conv = mkName . filter (`notElem` "()") . prettyPrint
instance Convert HS.Match TH.Clause where
conv (HS.Match _ _ ps _ bod ds) = Clause (c ps) (c bod) (c ds)
instance Convert HS.Rhs TH.Body where
conv (UnGuardedRhs x) = NormalB (c x)
conv (GuardedRhss x) = GuardedB (c x)
instance Convert HS.Exp TH.Exp where
conv (Con (Special UnitCon)) = TupE []
conv (Var x) = VarE (c x)
conv (Con x) = ConE (c x)
conv (Lit x) = LitE (c x)
conv (App x y) = AppE (c x) (c y)
conv (Paren x) = c x
conv (InfixApp x y z) = InfixE (Just $ c x) (c y) (Just $ c z)
conv (LeftSection x y) = InfixE (Just $ c x) (c y) Nothing
conv (RightSection y z) = InfixE Nothing (c y) (Just $ c z)
conv (Lambda _ x y) = LamE (c x) (c y)
conv (Tuple _ x) = TupE (c x)
conv (If x y z) = CondE (c x) (c y) (c z)
conv (Let x y) = LetE (c x) (c y)
conv (Case x y) = CaseE (c x) (c y)
conv (Do x) = DoE (c x)
conv (EnumFrom x) = ArithSeqE $ FromR (c x)
conv (EnumFromTo x y) = ArithSeqE $ FromToR (c x) (c y)
conv (EnumFromThen x y) = ArithSeqE $ FromThenR (c x) (c y)
conv (EnumFromThenTo x y z) = ArithSeqE $ FromThenToR (c x) (c y) (c z)
conv (List x) = ListE (c x)
conv (ExpTypeSig _ x y) = SigE (c x) (c y)
conv (RecConstr x y) = RecConE (c x) (c y)
conv (RecUpdate x y) = RecUpdE (c x) (c y)
-- Work around bug 3395, convert to do notation instead
conv (ListComp x y) = CompE $ c $ y ++ [QualStmt $ Qualifier x]
instance Convert HS.GuardedRhs (TH.Guard, TH.Exp) where
conv = undefined
instance Convert HS.Binds [TH.Dec] where
conv (BDecls x) = c x
instance Convert (Maybe HS.Binds) [TH.Dec] where
conv Nothing = []
conv (Just x) = c x
instance Convert HS.Pat TH.Pat where
conv (PParen x) = c x
conv (PLit Signless x) = LitP (c x)
conv (PTuple _ x) = TupP (c x)
conv (PApp x y) = ConP (c x) (c y)
conv (PVar x) = VarP (c x)
conv (PInfixApp x y z) = InfixP (c x) (c y) (c z)
conv (PIrrPat x) = TildeP (c x)
conv (PAsPat x y) = AsP (c x) (c y)
conv (PWildCard) = WildP
conv (PRec x y) = RecP (c x) (c y)
conv (PList x) = ListP (c x)
conv (PatTypeSig _ x y) = SigP (c x) (c y)
instance Convert HS.Literal TH.Lit where
conv (Char x) = CharL x
conv (String x) = StringL x
conv (Int x) = IntegerL x
conv (Frac x) = RationalL x
conv (PrimInt x) = IntPrimL x
conv (PrimWord x) = WordPrimL x
conv (PrimFloat x) = FloatPrimL x
conv (PrimDouble x) = DoublePrimL x
instance Convert HS.QName TH.Name where
conv (UnQual x) = c x
conv (Qual m x) = c (Ident $ prettyPrint m ++ "." ++ prettyPrint x)
conv (Special (TupleCon Boxed i)) = Name (mkOccName $ "(" ++ replicate (i-1) ',' ++ ")") NameS
instance Convert HS.PatField TH.FieldPat where
conv = undefined
instance Convert HS.QOp TH.Exp where
conv (QVarOp x) = c $ Var x
conv (QConOp x) = c $ Con x
instance Convert HS.Alt TH.Match where
conv (Alt _ x y z) = TH.Match (c x) (c y) (c z)
instance Convert HS.Stmt TH.Stmt where
conv (Generator _ x y) = BindS (c x) (c y)
conv (LetStmt x) = LetS (c x)
conv (Qualifier x) = NoBindS (c x)
instance Convert HS.QualStmt TH.Stmt where
conv (QualStmt x) = c x
instance Convert HS.FieldUpdate TH.FieldExp where
conv (FieldUpdate x y) = (c x, c y)
instance Convert HS.TyVarBind TH.Name where
conv (UnkindedVar x) = c x
#if __GLASGOW_HASKELL__ >= 612
instance Convert TH.TyVarBndr HS.TyVarBind where
conv (PlainTV x) = UnkindedVar $ c x
conv (KindedTV x y) = KindedVar (c x) $ c y
#if __GLASGOW_HASKELL__ < 706
instance Convert TH.Kind HS.Kind where
conv StarK = KindStar
conv (ArrowK x y) = KindFn (c x) $ c y
#else
instance Convert TH.Kind HS.Kind where
conv StarT = KindStar
conv (AppT (AppT ArrowT x) y) = KindFn (c x) (c y)
#endif
#if __GLASGOW_HASKELL__ < 709
instance Convert TH.Pred HS.Asst where
conv (ClassP x y) = ClassA (UnQual $ c x) $ c y
conv (TH.EqualP x y) = HS.EqualP (c x) $ c y
instance Convert HS.Asst TH.Pred where
conv (ClassA x y) = ClassP (c x) $ c y
conv (HS.EqualP x y) = TH.EqualP (c x) $ c y
#endif
instance Convert HS.TyVarBind TH.TyVarBndr where
conv (UnkindedVar x) = PlainTV $ c x
conv (KindedVar x y) = KindedTV (c x) $ c y
#if __GLASGOW_HASKELL__ < 706
instance Convert HS.Kind TH.Kind where
conv KindStar = StarK
conv (KindFn x y) = ArrowK (c x) $ c y
#else
instance Convert HS.Kind TH.Kind where
conv KindStar = StarT
conv (KindFn x y) = AppT (AppT ArrowT (c x)) (c y)
#endif
#endif
derive-2.5.23/Language/Haskell/TH/ 0000755 0000000 0000000 00000000000 12623341654 014676 5 ustar 00 0000000 0000000 derive-2.5.23/Language/Haskell/TH/Peephole.hs 0000644 0000000 0000000 00000013067 12623341654 017002 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards #-}
module Language.Haskell.TH.Peephole(peephole, replaceVar, replaceVars) where
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Helper
import Data.Generics
import Data.Maybe
import Data.List
import Debug.Trace
traceMode = False
peephole :: Data a => a -> a
peephole = everywhere (mkT peep) . everywhere (mkT peepPat)
-- find a given string, and replace it with a particular expression
-- must succeed, so crashes readily (deliberately!)
replaceVars :: [(Name,Exp)] -> Exp -> Exp
replaceVars rep orig = fExp orig
where
fExp x = case x of
VarE y -> fromMaybe x $ lookup y rep
ConE _ -> x
LitE _ -> x
AppE x y -> AppE (fExp x) (fExp y)
CaseE x y -> CaseE (fExp x) (map fMatch y)
TupE xs -> TupE (map fExp xs)
ListE xs -> ListE (map fExp xs)
LamE x y -> LamE x (fPat x y)
_ | null $ map fst rep `intersect` getNames x -> x
_ -> error $ "replaceVar: " ++ show x
getNames x = everything (++) ([] `mkQ` f) x
where
f :: Name -> [Name]
f x = [x]
fMatch o@(Match pat (NormalB bod) []) =
Match pat (NormalB $ fPat [pat] bod) []
-- given these pattern have come into scope
-- continue matching on the rest
fPat :: [Pat] -> Exp -> Exp
fPat pat = replaceVars (filter ((`notElem` used) . fst) rep)
where used = concatMap usedPats pat
usedPats x = everything (++) ([] `mkQ` f) x
where
f (VarP x) = [x]
f _ = []
replaceVar :: Name -> Exp -> Exp -> Exp
replaceVar name with = replaceVars [(name,with)]
-- based on the rewrite combinator in Play
peep :: Exp -> Exp
peep (ListE xs)
| not (null xs) && all (isJust . fromLitChar) xs =
peep $ LitE $ StringL $ map (fromJust . fromLitChar) xs
where
fromLitChar (LitE (CharL x)) = Just x
fromLitChar _ = Nothing
peep (AppE x y)
| x ~= "id" = y
peep (AppE (AppE op x) y)
| Just res <- peepBin op x y = res
peep (InfixE (Just x) op (Just y))
| Just res <- peepBin op x y = res
peep (LamE [] x) = x
peep (LamE [VarP x] (VarE y))
| x == y = l0 "id"
peep (DoE [NoBindS x]) = x
peep x@(ConE _)
| x ~= "[]" = ListE []
peep (AppE (AppE cons x) nil)
| cons ~= ":" && nil ~= "[]" = ListE [x]
peep (DoE [BindS (VarP p) (AppE ret (LitE val)),NoBindS e])
| ret ~= "return" = peep $ replaceVar p (LitE val) e
peep (LamE [TupP [VarP x, VarP y]] (VarE z))
| x == z = l0 "fst"
| y == z = l0 "snd"
peep (AppE (LamE (VarP x:xs) y) z)
| simple z
= peep $ LamE xs (replaceVar x z y)
peep (AppE (AppE bind (AppE ret x)) y)
| bind ~= ">>=" && ret ~= "return" = peep $ AppE y x
peep (InfixE (Just (AppE ret x)) bind (Just y))
| bind ~= ">>=" && ret ~= "return" = peep $ AppE y x
peep (InfixE (Just (AppE pure x)) ap y)
| ap ~= "<*>" && pure ~= "pure" = peep $ InfixE (Just x) (l0 "<$>") y
peep (InfixE (Just x) fmap (Just (AppE pure y)))
| fmap ~= "<$>" && pure ~= "pure" = peep $ AppE pure (peep $ AppE x y)
peep (AppE append (ListE [x]))
| append ~= "++" = peep $ AppE (l0 ":") x
peep (InfixE (Just (ListE [x])) append y)
| append ~= "++" = peep $ InfixE (Just x) (l0 ":") y
peep (InfixE (Just x) cons (Just (ListE xs)))
| cons ~= ":" = peep $ ListE (x:xs)
peep (AppE (AppE (AppE comp f) g) x)
| comp ~= "." = peep $ AppE f (peep $ AppE g x)
peep (AppE (InfixE (Just f) comp (Just g)) x)
| comp ~= "." = peep $ AppE f (peep $ AppE g x)
peep (AppE (AppE (AppE flip f) x) y)
| flip ~= "flip" = peep $ AppE (AppE f y) x
peep (AppE (InfixE (Just x) op Nothing) y) = peep $ InfixE (Just x) op (Just y)
peep (AppE (InfixE Nothing op (Just y)) x) = peep $ InfixE (Just x) op (Just y)
peep (AppE f (LamE x (ListE [y])))
| f ~= "concatMap" = peep $ AppE (l0 "map") (peep $ LamE x y)
peep (AppE f (ListE xs))
| f ~= "head" && not (null xs) = head xs
| f ~= "reverse" = ListE $ reverse xs
peep (AppE f (TupE [x,y]))
| f ~= "choose" && x == y = peep $ AppE (VarE (mkName "return")) x
peep (AppE (AppE sq o@(AppE rnf x)) (TupE []))
| sq ~= "seq" && rnf ~= "rnf" = o
peep (CaseE (LitE x) (Match (LitP y) (NormalB z) [] : _))
| x == y = z
peep (AppE len (ListE xs))
| len ~= "length" = LitE $ IntegerL $ toInteger $ length xs
peep (TupE [x]) = x
peep (AppE (LamE [pat] x) e) = CaseE e [Match pat (NormalB x) []]
peep (AppE (CaseE e [Match p (NormalB x) []]) y)
= CaseE e [Match p (NormalB $ peep $ AppE x y) []]
-- allow easy flip to tracing mode
peep x | traceMode = trace (show x) x
peep x = x
peepPat :: Pat -> Pat
peepPat (ListP xs)
| all (\x -> case x of LitP (CharL _) -> True
_ -> False) xs =
LitP $ StringL $ map (\(LitP (CharL x)) -> x) xs
peepPat x = x
peepBin :: Exp -> Exp -> Exp -> Maybe Exp
peepBin op x y
| op ~= "." && x ~= "id" = Just y
| op ~= "." && y ~= "id" = Just x
| op ~= "&&" && y ~= "True" = Just x
| op ~= "const" = Just x
| op ~= "map" && x ~= "id" = Just y
| op ~= "++" && x ~= "[]" = Just y
| op ~= "++" && y ~= "[]" = Just x
| op ~= "." && y ~= "id" = Just x
| op ~= ">>" && x ~= "return" && y == TupE [] = Just $ l0 "id"
| op ~= "$" = Just $ peep $ AppE x y
peepBin op (LitE (StringL x)) (LitE (StringL y))
| op ~= "++" = Just $ LitE $ StringL (x++y)
peepBin _ _ _ = Nothing
(VarE f) ~= x = show f == x
(ConE f) ~= x = show f == x
(ListE []) ~= "[]" = True
_ ~= _ = False
simple (VarE _) = True
simple (LitE _) = True
simple _ = False
derive-2.5.23/Language/Haskell/TH/Helper.hs 0000644 0000000 0000000 00000016256 12623341654 016463 0 ustar 00 0000000 0000000 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-- | These small short-named functions are intended to make the
-- construction of abstranct syntax trees less tedious.
module Language.Haskell.TH.Helper where
import Data.Char
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Data
import Language.Haskell.TH.Compat
-- * Special folds for the guessing
applyWith, foldl1With, foldr1With :: Exp -> [Exp] -> Exp
applyWith join xs = foldl AppE join xs
foldl1With join xs = foldr1 (\y x -> AppE (AppE join y) x) xs
foldr1With join xs = foldr1 (\y x -> AppE (AppE join x) y) xs
-- * Syntax elements
--
-- | A simple clause, without where or guards.
sclause :: [Pat] -> Exp -> Clause
sclause pats body = Clause pats (NormalB body) []
-- | A default clause with N arguments.
defclause :: Int -> Exp -> Clause
defclause num = sclause (replicate num WildP)
-- | A simple Val clause
sval :: Pat -> Exp -> Dec
sval pat body = ValD pat (NormalB body) []
case' :: Exp -> [(Pat, Exp)] -> Exp
case' exp alts = CaseE exp [ Match x (NormalB y) [] | (x,y) <- alts ]
(->:) :: String -> Exp -> Exp
(->:) nm bdy = LamE [vr nm] bdy
-- | We provide 3 standard instance constructors
-- instance_default requires C for each free type variable
-- instance_none requires no context
-- instance_context requires a given context
instance_none :: String -> DataDef -> [Dec] -> Dec
instance_none = instance_context []
instance_default :: String -> DataDef -> [Dec] -> Dec
instance_default n = instance_context [n] n
instance_context :: [String] -> String -> DataDef -> [Dec] -> Dec
instance_context req cls dat defs = InstanceD ctx hed defs
where
vrs = vars 't' (dataArity dat)
hed = l1 cls (lK (dataName dat) vrs)
ctx = [typeToPred $ l1 r v | r <- req, v <- vrs]
-- | Build an instance of a class for a data type, using the heuristic
-- that the type is itself required on all type arguments.
simple_instance :: String -> DataDef -> [Dec] -> [Dec]
simple_instance cls dat defs = [instance_default cls dat defs]
-- | Build an instance of a class for a data type, using the class at the given types
generic_instance :: String -> DataDef -> [Type] -> [Dec] -> [Dec]
generic_instance cls dat ctxTypes defs = [InstanceD ctx hed defs]
where
vrs = vars 't' (dataArity dat)
hed = l1 cls (lK (dataName dat) vrs)
ctx = map (typeToPred . l1 cls) ctxTypes
-- | Build a type signature declaration with a string name
sigN :: String -> Type -> Dec
sigN nam ty = SigD (mkName nam) ty
-- | Build a fundecl with a string name
funN :: String -> [Clause] -> Dec
funN nam claus = FunD (mkName nam) claus
-- * Pattern vs Value abstraction
class Eq nm => NameLike nm where
toName :: nm -> Name
instance NameLike Name where toName = id
instance NameLike String where toName = mkName
-- | The class used to overload lifting operations. To reduce code
-- duplication, we overload the wrapped constructors (and everything
-- else, but that's irrelevant) to work in patterns, expressions, and
-- types.
class Valcon a where
-- | Build an application node, with a name for a head and a
-- provided list of arguments.
lK :: NameLike nm => nm -> [a] -> a
-- | Reference a named variable.
vr :: NameLike nm => nm -> a
-- | Lift a TH 'Lit'
raw_lit :: Lit -> a
-- | Tupling
tup :: [a] -> a
-- | Listing
lst :: [a] -> a
instance Valcon Exp where
lK nm ys = let name = toName nm in case (nameBase name, ys) of
("[]", []) -> ConE name
("[]", xs) -> lst xs
((x:_), args) | isUpper x || x == ':' -> foldl AppE (ConE name) args
((x:_), [a,b]) | isOper x -> InfixE (Just a) (VarE name) (Just b)
where isOper x = not (isAlpha x || x == '_')
(nm, args) -> foldl AppE (VarE name) args
vr = VarE . toName
raw_lit = LitE
tup = TupE
lst = ListE
instance Valcon Pat where
lK = ConP . toName
vr = VarP . toName
raw_lit = LitP
tup = TupP
lst = ListP
instance Valcon Type where
lK nm = foldl AppT (if bNm == "[]" then ListT else ConT (mkName bNm))
where bNm = nameBase (toName nm)
vr = VarT . toName
raw_lit = error "raw_lit @ Type"
-- XXX work around bug in GHC < 6.10
-- (see http://hackage.haskell.org/trac/ghc/ticket/2358 for details)
tup [t] = t
tup ts = foldl AppT (TupleT (length ts)) ts
lst = error "lst @ Type"
-- | Build an application node without a given head
app :: Exp -> [Exp] -> Exp
app root args = foldl AppE root args
-- | This class is used to overload literal construction based on the
-- type of the literal.
class LitC a where
lit :: Valcon p => a -> p
instance LitC Integer where
lit = raw_lit . IntegerL
instance LitC Char where
lit = raw_lit . CharL
instance LitC a => LitC [a] where
lit = lst . map lit
instance (LitC a, LitC b) => LitC (a,b) where
lit (x,y) = tup [lit x, lit y]
instance (LitC a, LitC b, LitC c) => LitC (a,b,c) where
lit (x,y,z) = tup [lit x, lit y, lit z]
instance LitC () where
lit () = tup []
-- * Constructor abstraction
dataVars :: DataDef -> [Type]
dataVars dat = take (dataArity dat) $ map (VarT . mkName . return) ['a'..]
-- | Common pattern: list of a familiy of variables
vars :: Valcon a => Char -> Int -> [a]
vars c n = map (vrn c) [1 .. n]
-- | Variable based on a letter + number
vrn :: Valcon a => Char -> Int -> a
vrn c n = vr (c : show n)
-- | Make a list of variables, one for each argument to a constructor
ctv :: Valcon a => CtorDef -> Char -> [a]
ctv ctor c = vars c (ctorArity ctor)
-- | Make a simple pattern to bind a constructor
ctp :: Valcon a => CtorDef -> Char -> a
ctp ctor c = lK (ctorName ctor) (ctv ctor c)
-- | Reference the constructor itself
ctc :: Valcon a => CtorDef -> a
ctc = l0 . ctorName
-- * Lift a constructor over a fixed number of arguments.
l0 :: (NameLike nm, Valcon a) => nm -> a
l1 :: (NameLike nm, Valcon a) => nm -> a -> a
l2 :: (NameLike nm, Valcon a) => nm -> a -> a -> a
l0 s = lK s []
l1 s a = lK s [a]
l2 s a b = lK s [a,b]
-- * Pre-lifted versions of common operations
true, false, nil :: Valcon a => a
hNil', hZero' :: Type
true = l0 "True"
false = l0 "False"
nil = l0 "[]"
unit = lit ()
hNil' = l0 "HNil"
hZero' = l0 "HZero"
id' = l0 "id"
cons :: Valcon a => a -> a -> a
cons = l2 ":"
box :: Valcon a => a -> a
return', const' :: Exp -> Exp
hSucc' :: Type -> Type
box x = cons x nil
return' = l1 "return"
const' = l1 "const"
hSucc' = l1 "HSucc"
(==:), (&&:), (++:), (>>=:), (>>:), (.:), ap', (>:) :: Exp -> Exp -> Exp
hCons' :: Type -> Type -> Type
(==:) = l2 "=="
(&&:) = l2 "&&"
(++:) = l2 "++"
(>>=:) = l2 ">>="
(>>:) = l2 ">>"
(.:) = l2 "."
(>:) = l2 ">"
ap' = l2 "ap"
hCons' = l2 "HCons"
-- | Build a chain of expressions, with an appropriate terminal
-- sequence__ does not require a unit at the end (all others are optimised automatically)
(&&::), (++::), (>>::), sequence__, (.::) :: [Exp] -> Exp
(&&::) = foldr (&&:) true
(++::) = foldr (++:) nil
(>>::) = foldr (>>:) (return' unit)
(.::) = foldr (.:) id'
sequence__ [] = return' unit
sequence__ xs = foldr1 (>>:) xs
-- | K-way liftM
liftmk :: Exp -> [Exp] -> Exp
liftmk hd args = foldl ap' (return' hd) args
derive-2.5.23/Language/Haskell/TH/FixedPpr.hs 0000644 0000000 0000000 00000035547 12623341654 016771 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell, CPP #-}
-- TH.Ppr contains a prettyprinter for the
-- Template Haskell datatypes
module Language.Haskell.TH.FixedPpr where
-- All of the exports from this module should
-- be "public" functions. The main module TH
-- re-exports them all.
import Text.PrettyPrint.HughesPJ (render)
import Language.Haskell.TH.PprLib
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Data(isTupleT)
import Data.Char ( toLower, isAlpha )
nestDepth :: Int
nestDepth = 4
type Precedence = Int
appPrec, opPrec, noPrec :: Precedence
appPrec = 2 -- Argument of a function application
opPrec = 1 -- Argument of an infix operator
noPrec = 0 -- Others
parensIf :: Bool -> Doc -> Doc
parensIf True d = parens d
parensIf False d = d
------------------------------
-- Show name with `` and () stripped, so that behaviour is the same
-- with fixed and broken syntax-libs
showNameRaw :: Name -> String
showNameRaw = clean . show
where
clean ('(':xs) = init xs
clean ('`':xs) = init xs
clean xs = xs
isPrefixName :: Name -> Bool
isPrefixName = classify . showNameRaw
where
classify xs = case break (=='.') xs of
(_,(_:xs')) -> classify xs'
((x:xs),[]) -> isAlpha x || x == '_'
_ -> False -- operators ending with .
pprName_ :: Bool -> Name -> Doc
pprName_ True nm | isPrefixName nm = text (showNameRaw nm)
| otherwise = text ("(" ++ showNameRaw nm ++ ")")
pprName_ False nm | isPrefixName nm = text ("`" ++ showNameRaw nm ++ "`")
| otherwise = text (showNameRaw nm)
------------------------------
pprint :: Ppr a => a -> String
pprint x = render $ to_HPJ_Doc $ ppr x
class Ppr a where
ppr :: a -> Doc
ppr_list :: [a] -> Doc
ppr_list = vcat . map ppr
instance Ppr a => Ppr [a] where
ppr x = ppr_list x
------------------------------
instance Ppr Name where
ppr v = pprName_ True v -- text (show v)
------------------------------
instance Ppr Info where
#if __GLASGOW_HASKELL__ >= 700
ppr (ClassI d _) = ppr d
#else
ppr (ClassI d) = ppr d
#endif
ppr (TyConI d) = ppr d
ppr (PrimTyConI name arity is_unlifted)
= text "Primitive"
<+> (if is_unlifted then text "unlifted" else empty)
<+> text "type construtor" <+> quotes (ppr name)
<+> parens (text "arity" <+> int arity)
ppr (ClassOpI v ty cls fix)
= text "Class op from" <+> ppr cls <> colon <+>
vcat [ppr_sig v ty, pprFixity v fix]
ppr (DataConI v ty tc fix)
= text "Constructor from" <+> ppr tc <> colon <+>
vcat [ppr_sig v ty, pprFixity v fix]
ppr (TyVarI v ty)
= text "Type variable" <+> ppr v <+> equals <+> ppr ty
ppr (VarI v ty mb_d fix)
= vcat [ppr_sig v ty, pprFixity v fix,
case mb_d of { Nothing -> empty; Just d -> ppr d }]
ppr_sig v ty = ppr v <+> text "::" <+> ppr ty
pprFixity :: Name -> Fixity -> Doc
pprFixity v f | f == defaultFixity = empty
pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
where ppr_fix InfixR = text "infixr"
ppr_fix InfixL = text "infixl"
ppr_fix InfixN = text "infix"
------------------------------
instance Ppr Exp where
ppr = pprExp noPrec
pprExpInfix :: Exp -> Doc
pprExpInfix (VarE v) = pprName_ False v
pprExpInfix (ConE c) = pprName_ False c
pprExp :: Precedence -> Exp -> Doc
pprExp _ (VarE v) = ppr v
pprExp _ (ConE c)
| isTupleT (ConT c) = text (nameBase c)
| c == '[] = text ("[]")
| c == '(:) = text ("(:)")
| otherwise = ppr c
pprExp i (LitE l) = pprLit i l
pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
<+> pprExp appPrec e2
pprExp i (InfixE (Just e1) op (Just e2))
= parensIf (i >= opPrec) $ pprExp opPrec e1
<+> pprExpInfix op
<+> pprExp opPrec e2
pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1
<+> pprExpInfix op
<+> pprMaybeExp noPrec me2
pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)
<+> text "->" <+> ppr e
pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es
-- Nesting in Cond is to avoid potential problems in do statments
pprExp i (CondE guard true false)
= parensIf (i > noPrec) $ sep [text "if" <+> ppr guard,
nest 1 $ text "then" <+> ppr true,
nest 1 $ text "else" <+> ppr false]
pprExp i (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds
$$ text " in" <+> ppr e
pprExp i (CaseE e ms)
= parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"
$$ nest nestDepth (ppr ms)
pprExp i (DoE ss) = parensIf (i > noPrec) $ text "do" <+> ppr ss
pprExp _ (CompE []) = error "Can't happen: pprExp (CompExp [])"
-- This will probably break with fixity declarations - would need a ';'
pprExp _ (CompE ss) = text "[" <> ppr s
<+> text "|"
<+> (sep $ punctuate comma $ map ppr ss')
<> text "]"
where s = last ss
ss' = init ss
pprExp _ (ArithSeqE d) = ppr d
pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es
pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t
pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
pprFields :: [(Name,Exp)] -> Doc
pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
pprMaybeExp :: Precedence -> Maybe Exp -> Doc
pprMaybeExp _ Nothing = empty
pprMaybeExp i (Just e) = pprExp i e
------------------------------
instance Ppr Stmt where
ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
ppr (LetS ds) = text "let" <+> ppr ds
ppr (NoBindS e) = ppr e
ppr (ParS sss) = sep $ punctuate (text "|")
$ map (sep . punctuate comma . map ppr) sss
------------------------------
instance Ppr Match where
ppr (Match p rhs ds) = ppr p <+> pprBody False rhs
$$ where_clause ds
------------------------------
pprBody :: Bool -> Body -> Doc
pprBody eq (GuardedB xs) = nest nestDepth $ vcat $ map do_guard xs
where eqd = if eq then text "=" else text "->"
do_guard (NormalG g, e) = text "|" <+> ppr g <+> eqd <+> ppr e
do_guard (PatG ss, e) = text "|" <+> vcat (map ppr ss)
$$ nest nestDepth (eqd <+> ppr e)
pprBody eq (NormalB e) = (if eq then text "=" else text "->") <+> ppr e
instance Ppr Body where
ppr = pprBody True
------------------------------
pprLit :: Precedence -> Lit -> Doc
pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0)
(integer x <> char '#')
pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0)
(float (fromRational x) <> char '#')
pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)
(double (fromRational x) <> text "##")
pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x)
pprLit _ (CharL c) = text (show c)
pprLit _ (StringL s) = text (show s)
pprLit i (RationalL rat) = parensIf (i > noPrec) $ rational rat
instance Ppr Lit where
ppr = pprLit 10
------------------------------
instance Ppr Pat where
ppr = pprPat noPrec
pprPat :: Precedence -> Pat -> Doc
pprPat i (LitP l) = pprLit i l
pprPat _ (VarP v) = ppr v
pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps
pprPat i (ConP s ps) = parensIf (i > noPrec) $ x
<+> sep (map (pprPat appPrec) ps)
where
x | isTupleT (ConT s) = text (nameBase s)
| s == '[] = text "[]"
| s == '(:) = text "(:)"
| otherwise = ppr s
pprPat i (InfixP p1 n p2)
= parensIf (i > noPrec)
$ pprPat opPrec p1 <+> pprName_ False n <+> pprPat opPrec p2
pprPat i (TildeP p) = parensIf (i > noPrec) $ text "~" <> pprPat appPrec p
pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@"
<> pprPat appPrec p
pprPat _ WildP = text "_"
pprPat _ (RecP nm fs)
= parens $ ppr nm
<+> braces (sep $ punctuate comma $
map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)
pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps
pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t
------------------------------
instance Ppr Dec where
ppr (FunD f cs) = vcat $ map (\c -> ppr f <+> ppr c) cs
ppr (ValD p r ds) = ppr p <+> pprBody True r
$$ where_clause ds
ppr (TySynD t xs rhs) = text "type" <+> ppr t <+> hsep (map ppr xs)
<+> text "=" <+> ppr rhs
ppr (DataD ctxt t xs cs decs)
= text "data"
<+> pprCxt ctxt
<+> ppr t <+> hsep (map ppr xs)
<+> sep (pref $ map ppr cs)
$$ if null decs
then empty
else nest nestDepth
$ text "deriving"
<+> parens (hsep $ punctuate comma $ map ppr decs)
where pref :: [Doc] -> [Doc]
pref [] = [] -- Can't happen in H98
pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
ppr (NewtypeD ctxt t xs c decs)
= text "newtype"
<+> pprCxt ctxt
<+> ppr t <+> hsep (map ppr xs)
<+> char '=' <+> ppr c
$$ if null decs
then empty
else nest nestDepth
$ text "deriving"
<+> parens (hsep $ punctuate comma $ map ppr decs)
ppr (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt
<+> ppr c <+> hsep (map ppr xs) <+> ppr fds
$$ where_clause ds
ppr (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
$$ where_clause (map deQualLhsHead ds)
ppr (SigD f t) = ppr f <+> text "::" <+> ppr t
ppr (ForeignD f) = ppr f
deQualLhsHead :: Dec -> Dec
deQualLhsHead (FunD n cs) = FunD (deQualName n) cs
deQualLhsHead (ValD p b ds) = ValD (go p) b ds
where
go (VarP n) = VarP (deQualName n)
go (InfixP p1 n p2) = InfixP p1 (deQualName n) p2
go x = x
deQualLhsHead x = x
deQualName :: Name -> Name
deQualName = mkName . nameBase
------------------------------
instance Ppr FunDep where
ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs))
------------------------------
instance Ppr Foreign where
ppr (ImportF callconv safety impent as typ)
= text "foreign import"
<+> showtextl callconv
<+> showtextl safety
<+> text (show impent)
<+> ppr as
<+> text "::" <+> ppr typ
ppr (ExportF callconv expent as typ)
= text "foreign export"
<+> showtextl callconv
<+> text (show expent)
<+> ppr as
<+> text "::" <+> ppr typ
------------------------------
instance Ppr Clause where
ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs
$$ where_clause ds
------------------------------
instance Ppr Con where
ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts)
ppr (RecC c vsts)
= ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts))
ppr (InfixC st1 c st2) = pprStrictType st1 <+> pprName_ False c <+> pprStrictType st2
ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns)
<+> char '.' <+> pprCxt ctxt <+> ppr con
------------------------------
pprVarStrictType :: (Name, Strict, Type) -> Doc
-- Slight infelicity: with print non-atomic type with parens
pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t)
------------------------------
pprStrictType :: (Strict, Type) -> Doc
-- Prints with parens if not already atomic
pprStrictType (IsStrict, t) = char '!' <> pprParendType t
pprStrictType (NotStrict, t) = pprParendType t
------------------------------
pprParendType :: Type -> Doc
pprParendType (VarT v) = ppr v
pprParendType (ConT c)
| c == ''[] = pprParendType ListT
| c == ''(->) = pprParendType ArrowT
| isTupleT (ConT c) = pprParendType (TupleT (length (nameBase c) - 1))
| otherwise = ppr c
pprParendType (TupleT 0) = text "()"
pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))
pprParendType ArrowT = parens (text "->")
pprParendType ListT = text "[]"
pprParendType other = parens (ppr other)
instance Ppr Type where
ppr (ForallT tvars ctxt ty) =
text "forall" <+> hsep (map ppr tvars) <+> text "."
<+> pprCxt ctxt <+> ppr ty
#if __GLASGOW_HASKELL__ >= 706
ppr StarT = text "*"
#endif
ppr ty = pprTyApp (split ty)
pprTyApp :: (Type, [Type]) -> Doc
pprTyApp (ArrowT, [arg1,arg2]) = sep [ppr arg1 <+> text "->", ppr arg2]
pprTyApp (ListT, [arg]) = brackets (ppr arg)
pprTyApp (TupleT n, args)
| length args == n = parens (sep (punctuate comma (map ppr args)))
pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)
split :: Type -> (Type, [Type]) -- Split into function and args
split t = go t []
where go (AppT t1 t2) args = go t1 (t2:args)
go ty args = (ty, args)
------------------------------
pprCxt :: Cxt -> Doc
pprCxt [] = empty
pprCxt [t] = ppr t <+> text "=>"
pprCxt ts = parens (hsep $ punctuate comma $ map ppr ts) <+> text "=>"
------------------------------
instance Ppr Range where
ppr = brackets . pprRange
where pprRange :: Range -> Doc
pprRange (FromR e) = ppr e <> text ".."
pprRange (FromThenR e1 e2) = ppr e1 <> text ","
<> ppr e2 <> text ".."
pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2
pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","
<> ppr e2 <> text ".."
<> ppr e3
------------------------------
where_clause :: [Dec] -> Doc
where_clause [] = empty
where_clause ds = nest nestDepth $ text "where" <+> vcat (map ppr ds)
showtextl :: Show a => a -> Doc
showtextl = text . map toLower . show
#if __GLASGOW_HASKELL__ >= 612
instance Ppr TyVarBndr where
ppr (PlainTV v) = ppr v
ppr (KindedTV v k) = parens $ ppr v <+> text "::" <+> ppr k
#if __GLASGOW_HASKELL__ < 706
instance Ppr Kind where
ppr StarK = text "*"
ppr (ArrowK j k) = ppr j <+> text "->" <+> ppr k
#endif
#if __GLASGOW_HASKELL__ < 709
instance Ppr Pred where
ppr (ClassP n ts) = ppr n <+> hsep (map ppr ts)
ppr (EqualP t u ) = ppr t <+> text "~" <+> ppr u
#endif
#endif
derive-2.5.23/Language/Haskell/TH/ExpandSynonym.hs 0000644 0000000 0000000 00000004011 12623341654 020042 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards #-}
-- | Expand type synonyms in data declarations.
--
-- This is needed for some type based derivations.
module Language.Haskell.TH.ExpandSynonym (expandData) where
import Language.Haskell.TH
import Language.Haskell.TH.Compat
import Language.Haskell.TH.Data
import Data.Generics
-- | Expand type synonyms in a data declaration
expandData :: DataDef -> Q DataDef
expandData = everywhereM (mkM expandType)
expandType :: Type -> Q Type
expandType t = expandType' t []
-- Walk over a type, collecting applied arguments
expandType' :: Type -> [Type] -> Q Type
expandType' (AppT t arg) args = expandType' t (arg:args)
expandType' t@(ConT name) args = do result <- expandSyn name args
case result of
Just (t',args') -> everywhereM (mkM expandType) $ foldl AppT t' args'
_ -> return $ foldl AppT t args
expandType' t args = return $ foldl AppT t args
-- Is the name a type synonym and are there enough arguments? if so, apply it
expandSyn :: Name -> [Type] -> Q (Maybe (Type, [Type]))
expandSyn name args = recover (return Nothing) $ do
info <- reify name
case info of
TyConI (TySynD _ synArgs t) | length args >= length synArgs
-> return $ Just (substitute (map fromTyVar synArgs) argsInst t, argsMore) -- instantiate type synonym
where (argsInst,argsMore) = splitAt (length synArgs) args
_ -> return Nothing
-- `recover` return Nothing
-- Substitute names for types in a type
substitute :: [Name] -> [Type] -> Type -> Type
substitute ns ts = subst (zip ns ts)
where subst s (ForallT ns ctx t) = ForallT ns ctx (subst (filter ((`notElem` (map fromTyVar ns)) . fst) s) t)
subst s (VarT n)
| Just t' <- lookup n s = t'
subst s (AppT a b) = AppT (subst s a) (subst s b)
subst _ t = t
derive-2.5.23/Language/Haskell/TH/Data.hs 0000644 0000000 0000000 00000006130 12623341654 016103 0 ustar 00 0000000 0000000
-- | The core module of the Data.Derive system. This module contains
-- the data types used for communication between the extractors and
-- the derivors.
module Language.Haskell.TH.Data where
import Data.Char
import Data.Generics
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Compat
-- must be one of DataD or NewtypeD
type DataDef = Dec
type CtorDef = Con
dataName :: DataDef -> String
dataName (DataD _ name _ _ _) = unqualifiedName name
dataName (NewtypeD _ name _ _ _) = unqualifiedName name
qualifiedDataName :: DataDef -> Name
qualifiedDataName (DataD _ name _ _ _) = name
qualifiedDataName (NewtypeD _ name _ _ _) = name
dataArity :: DataDef -> Int
dataArity (DataD _ _ xs _ _) = length xs
dataArity (NewtypeD _ _ xs _ _) = length xs
dataArgs :: DataDef -> [Name]
dataArgs = dataDefinitionTypeArgs
dataCtors :: DataDef -> [CtorDef]
dataCtors (DataD _ _ _ xs _) = xs
dataCtors (NewtypeD _ _ _ x _) = [x]
ctorName :: CtorDef -> String
ctorName (NormalC name _ ) = unqualifiedName name
ctorName (RecC name _ ) = unqualifiedName name
ctorName (InfixC _ name _) = unqualifiedName name
ctorName (ForallC _ _ c ) = ctorName c
qualifiedCtorName :: CtorDef -> Name
qualifiedCtorName (NormalC name _ ) = name
qualifiedCtorName (RecC name _ ) = name
qualifiedCtorName (InfixC _ name _) = name
qualifiedCtorName (ForallC _ _ c ) = qualifiedCtorName c
ctorArity :: CtorDef -> Int
ctorArity (NormalC _ xs ) = length xs
ctorArity (RecC _ xs ) = length xs
ctorArity (InfixC _ _ _ ) = 2
ctorArity (ForallC _ _ c) = ctorArity c
ctorStrictTypes :: CtorDef -> [StrictType]
ctorStrictTypes (NormalC _ xs ) = xs
ctorStrictTypes (RecC _ xs ) = [(b,c) | (a,b,c) <- xs]
ctorStrictTypes (InfixC x _ y ) = [x,y]
ctorStrictTypes (ForallC _ _ c) = ctorStrictTypes c
ctorTypes :: CtorDef -> [Type]
ctorTypes = map snd . ctorStrictTypes
ctorFields :: CtorDef -> [String]
ctorFields (RecC name varStrictType) = [unqualifiedName name | (name,strict,typ) <- varStrictType]
ctorFields _ = []
-- normalisation
-- make sure you deal with "GHC.Base.."
dropModule :: String -> String
dropModule xs = case reverse xs of
('.':xs) -> takeWhile (== '.') xs
xs -> reverse $ takeWhile (/= '.') xs
-- i_123432 -> i
dropNumber :: String -> String
dropNumber xs = if all isDigit a then reverse (tail b) else xs
where (a,b) = break (== '_') $ reverse xs
normData :: DataDef -> DataDef
normData = everywhere (mkT normType)
where
normType :: Type -> Type
normType (ConT x) | show x == "[]" = ListT
normType x = x
unqualifiedName :: Name -> String
unqualifiedName = dropModule . show
-- convert AppT chains back to a proper list
typeApp :: Type -> (Type, [Type])
typeApp (AppT l r) = (a, b++[r])
where (a,b) = typeApp l
typeApp t = (t, [])
eqConT :: String -> Type -> Bool
eqConT name (ConT x) = name == show x
eqConT _ _ = False
isTupleT :: Type -> Bool
isTupleT (TupleT _) = True
isTupleT (ConT x) = head sx == '(' && last sx == ')' &&
all (== ',') (take (length sx - 2) (tail sx))
where sx = nameBase x
isTupleT _ = False
derive-2.5.23/Language/Haskell/TH/Compat.hs 0000644 0000000 0000000 00000001637 12623341654 016464 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
-- | Compatibility definitions to paper over differences between 6.10 and 6.12.
module Language.Haskell.TH.Compat where
import Language.Haskell.TH
#if __GLASGOW_HASKELL__ >= 612
fromTyVar :: TyVarBndr -> Name
fromTyVar (PlainTV v) = v
fromTyVar (KindedTV v _) = v
#else
fromTyVar :: Name -> Name
fromTyVar v = v
#endif
dataDefinitionTypeArgs :: Dec -> [Name]
#if __GLASGOW_HASKELL__ >= 612
dataDefinitionTypeArgs (DataD _cx name _ _ args) = args
dataDefinitionTypeArgs (NewtypeD cx name _ _ args) = args
#else
dataDefinitionTypeArgs (DataD _cx name args cons _derv) = args
dataDefinitionTypeArgs (NewtypeD cx name args con derv) = args
#endif
#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 709
typeToPred :: Type -> Pred
typeToPred (ConT v) = ClassP v []
typeToPred (AppT x y) = ClassP v (t++[y])
where ClassP v t = typeToPred x
#else
typeToPred :: Type -> Type
typeToPred x = x
#endif
derive-2.5.23/Language/Haskell/TH/All.hs 0000644 0000000 0000000 00000002077 12623341654 015750 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -w #-}
module Language.Haskell.TH.All (
module Language.Haskell.TH.All,
module Language.Haskell.TH.Syntax, module Language.Haskell.TH.Peephole,
module Language.Haskell.TH.Helper, module Language.Haskell.TH.FixedPpr,
module Language.Haskell.TH.Data, module Language.Haskell.TH.ExpandSynonym,
) where
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Peephole
import Language.Haskell.TH.Helper
import Language.Haskell.TH.FixedPpr
import Language.Haskell.TH.ExpandSynonym
import Language.Haskell.TH.Data
import Control.Monad
-- | The type of ways to derive classes.
-- Should not really be in this module!
data Derivation = Derivation {
derivationDeriver :: DataDef -> Q [Dec], -- ^ The derivation function proper
derivationName :: String -- ^ The name of the derivation
}
-- create a new derivation more abstractly
derivation :: (DataDef -> [Dec]) -> String -> Derivation
derivation f = Derivation (return . f)
derivationQ :: (DataDef -> Q [Dec]) -> String -> Derivation
derivationQ = Derivation
derive-2.5.23/Derive/ 0000755 0000000 0000000 00000000000 12623341654 012473 5 ustar 00 0000000 0000000 derive-2.5.23/Derive/Utils.hs 0000644 0000000 0000000 00000004714 12623341654 014135 0 ustar 00 0000000 0000000
module Derive.Utils where
import Data.Derive.DSL.HSE
import Data.List
import qualified Data.ByteString.Char8 as BS
import System.Directory
import System.IO
import System.FilePath
import Control.Monad
import Data.Maybe
data Src = Src
{srcName :: String
,srcImport :: [ImportDecl]
,srcExample :: Maybe [Decl]
,srcTest :: [(Type,[Decl])]
,srcCustom :: Bool
}
-- skip the importPkg bits
srcImportStd :: Src -> [ImportDecl]
srcImportStd y= [x{importPkg=Nothing} | x <- srcImport y]
nullSrc = Src "" [] Nothing [] False
readHSE :: FilePath -> IO Module
readHSE file = do
src <- readFile' file
src <- return $ takeWhile (/= "-}") $ drop 1 $ dropWhile (/= "{-") $
dropWhile (not . isPrefixOf "module ") $ lines src
let mode = defaultParseMode{extensions=map EnableExtension [MultiParamTypeClasses,FlexibleContexts,TemplateHaskell,PackageImports,TypeOperators]}
return $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src
data Pragma = Example Bool | Test Type
asPragma :: Decl -> Maybe Pragma
asPragma (TypeSig _ [x] t)
| x ~= "example" = Just $ Example $ prettyPrint t == "Custom"
| x ~= "test" = Just $ Test t
asPragma _ = Nothing
readSrc :: FilePath -> IO Src
readSrc file = do
modu <- readHSE file
return $ foldl f nullSrc{srcName=takeBaseName file, srcImport=moduleImports modu}
[ (p,xs)
| p:real <- tails $ moduleDecls modu, Just p <- [asPragma p]
, let xs = takeWhile (isNothing . asPragma) real ]
where
f src (Example x,bod) = src{srcExample = Just bod, srcCustom = x}
f src (Test x,bod) = src{srcTest = srcTest src ++ [(x,bod)]}
generatedStart = "-- GENERATED START"
generatedStop = "-- GENERATED STOP"
writeGenerated :: FilePath -> [String] -> IO ()
writeGenerated file x = do
src <- fmap lines $ readFile' file
let pre = takeWhile (/= generatedStart) src
post = drop 1 $ dropWhile (/= generatedStop) src
src2 = pre ++ [generatedStart] ++ x ++ [generatedStop] ++ post
when (src /= src2) $
seq (length src2) $ writeBinaryFile file $ unlines src2
readFile' :: FilePath -> IO String
readFile' file = do
b <- doesFileExist file
if b then fmap BS.unpack $ BS.readFile file else return []
writeBinaryFile :: FilePath -> String -> IO ()
writeBinaryFile file x = withBinaryFile file WriteMode (`hPutStr` x)
rep from to x = if x == from then to else x
reps from to = map (rep from to)
derive-2.5.23/Derive/Test.hs 0000644 0000000 0000000 00000007617 12623341654 013761 0 ustar 00 0000000 0000000
module Derive.Test(test) where
import Derive.Utils
import Data.Derive.DSL.HSE
import Control.Monad
import Data.Maybe
import Data.List
import System.FilePath
import System.Process
import System.Exit
import Control.Arrow
import Data.Derive.All
import Data.Derive.Internal.Derivation
-- These overlap with other derivations
overlaps =
[["BinaryDefer","EnumCyclic","LazySet","DataAbstract"]
,["Serialize"]]
-- REASONS:
-- UniplateDirect: Doesn't work through Template Haskell
-- Typeable cannot be separately derived in GHC 7.8
exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial","Binary","Typeable"]
-- These must be first and in every set
priority = ["Eq"]
listType :: Decl
listType = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"]
[QualConDecl sl [] [] (ConDecl (Ident "[]") [])
,QualConDecl sl [] [] (ConDecl (Ident "Cons")
[TyVar (Ident "a")
,TyApp (TyCon (UnQual (Ident "List"))) (TyVar (Ident "a"))])]
[]
-- test each derivation
test :: IO ()
test = do
decls <- fmap (filter isDataDecl . moduleDecls) $ readHSE "Data/Derive/Internal/Test.hs"
-- check the test bits
let ts = ("[]",listType) : map (dataDeclName &&& id) decls
mapM_ (testFile ts) derivations
-- check the $(derive) bits
putStrLn "Type checking examples"
let name = "AutoGenerated_Test"
devs <- sequence [liftM ((,) d) $ readSrc $ "Data/Derive" derivationName d <.> "hs" | d <- derivations]
let lookupDev x = fromMaybe (error $ "Couldn't find derivation: " ++ x) $ find ((==) x . derivationName . fst) devs
let sets = zip [1..] $ map (map lookupDev) $ map (priority++) $
[d | d <- map (derivationName . fst) devs, d `notElem` (exclude ++ priority ++ concat overlaps)] : overlaps
forM sets $ \(i,xs) -> autoTest (name++show i) decls xs
writeFile (name++".hs") $ unlines $
["import " ++ name ++ show (fst i) | i <- sets] ++ ["main = putStrLn \"Type checking successful\""]
res <- system $ "runhaskell " ++ name ++ ".hs"
when (res /= ExitSuccess) $ error "Failed to typecheck results"
testFile :: [(String,Decl)] -> Derivation -> IO ()
testFile types (Derivation name op) = do
putStrLn $ "Testing " ++ name
src <- readSrc $ "Data/Derive/" ++ name ++ ".hs"
forM_ (srcTest src) $ \(typ,res) -> do
let d = if tyRoot typ /= name then tyRoot typ else tyRoot $ head $ snd $ fromTyApps $ fromTyParen typ
let grab x = fromMaybe (error $ "Error in tests, couldn't resolve type: " ++ x) $ lookup x types
let Right r = op typ grab (ModuleName "Example", grab d)
when (not $ r `outEq` res) $
error $ "Results don't match!\nExpected:\n" ++ showOut res ++ "\nGot:\n" ++ showOut r ++ "\n\n" ++ detailedNeq res r
detailedNeq as bs | na /= nb = "Lengths don't match, " ++ show na ++ " vs " ++ show nb
where na = length as ; nb = length bs
detailedNeq as bs = "Mismatch on line " ++ show i ++ "\n" ++ show a ++ "\n" ++ show b
where (i,a,b) = head $ filter (\(i,a,b) -> a /= b) $ zip3 [1..] (noSl as) (noSl bs)
autoTest :: String -> [DataDecl] -> [(Derivation,Src)] -> IO ()
autoTest name ts ds =
writeFile (name++".hs") $ unlines $
["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses,TypeOperators,DeriveDataTypeable #-}"
,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields -fno-warn-unused-imports #-}"
,"module " ++ name ++ " where"
,"import Prelude"
,"import Data.DeriveTH"
,"import Data.Typeable"
,"import Derive.TestInstances()"] ++
[prettyPrint i | (_,s) <- ds, i <- srcImportStd s] ++
[prettyPrint t ++ "\n deriving Typeable" | t <- ts2] ++
["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | (d,_) <- ds]
where
types = "[" ++ intercalate "," ["''" ++ dataDeclName t | t <- ts2] ++ "]"
ts2 = filter (not . isBuiltIn) ts
isBuiltIn x = dataDeclName x `elem` ["Bool","Either"]
derive-2.5.23/Derive/Main.hs 0000644 0000000 0000000 00000004002 12623341654 013707 0 ustar 00 0000000 0000000
module Derive.Main(deriveMain) where
import Language.Haskell
import Data.Derive.All(Derivation)
import Derive.Derivation
import Derive.Generate
import Derive.Test
import Derive.Flags
import Data.List
import System.Directory
deriveMain :: [Derivation] -> IO ()
deriveMain derivations = do
(flags,files) <- getFlags
if Test `elem` flags then
test
else if Generate `elem` flags then
generate
else if Preprocessor `elem` flags then
(if length files /= 3 then
error $ "Expected to be invoked as a GHC preprocessor with 3 files, but got " ++ show (length files)
else do
copyFile (files !! 1) (files !! 2)
mainFile derivations (Append:flags) (files !! 2)
)
else if null files then
putStr $ "No files specified\n" ++ flagInfo
else
mapM_ (mainFile derivations flags) files
mainFile :: [Derivation] -> [Flag] -> FilePath -> IO ()
mainFile derivations flags file = do
src <- readFile file
src <- return $ unlines $ filter (not . isPrefixOf "#") $ lines src
let parse = fromParseResult . parseFileContentsWithMode defaultParseMode{parseFilename=file,extensions=defaultExtensions}
real = parse src
mine = parse $ uncomment src
flags <- return $ foldl addFlags flags
[(sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine]
let res = performDerive derivations mine $ wantDerive flags real mine
writeDerive file (moduleName mine) flags res
uncomment :: String -> String
uncomment ('{':'-':'!':xs) = ' ':' ':' ':uncomment xs
uncomment ('!':'-':'}':xs) = ' ':' ':' ':uncomment xs
uncomment (x:xs) = x:uncomment xs
uncomment [] = []
-- Taken from HLint, update occasionally
defaultExtensions :: [Extension]
defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions
badExtensions =
[Arrows -- steals proc
,TransformListComp -- steals the group keyword
,XmlSyntax, RegularPatterns -- steals a-b
]
derive-2.5.23/Derive/Generate.hs 0000644 0000000 0000000 00000010566 12623341654 014571 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 "Data/Derive"
xs <- return $ sort [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]
lis <- mapM generateFile $ map ("Data/Derive" ) xs
let names = map dropExtension xs
n = maximum $ map length names
writeGenerated "Data/Derive/All.hs" $
["import Data.Derive." ++ x ++ replicate (4 + n - length x) ' ' ++ "as D" | x <- names] ++
["derivations :: [Derivation]"
,"derivations = [make" ++ concat (intersperse ",make" names) ++ "]"]
writeGenerated "README.md" $ ["-->",""] ++ lis ++ ["","