reorderable (empty) → 0.3
raw patch · 10 files changed
+1540/−0 lines, 10 filesdep +basedep +constraintsdep +haskell-src-extssetup-changed
Dependencies added: base, constraints, haskell-src-exts, haskell-src-meta, template-haskell
Files
- LICENSE +358/−0
- Setup.hs +2/−0
- reorderable.cabal +211/−0
- src/Data/Types/Reorder.hs +52/−0
- src/Data/Types/Reorder/Base.hs +52/−0
- src/Data/Types/Reorder/Instances.hs +111/−0
- src/Data/Types/Reorder/Product.hs +236/−0
- src/Data/Types/Reorder/Quoter.hs +74/−0
- src/Data/Types/Reorder/Sum.hs +166/−0
- src/Data/Types/Reorder/TH.hs +278/−0
+ LICENSE view
@@ -0,0 +1,358 @@+Mozilla Public License, version 2.0 + +1. Definitions + +1.1. “Contributor” + + means each individual or legal entity that creates, contributes to the + creation of, or owns Covered Software. + +1.2. “Contributor Version” + + means the combination of the Contributions of others (if any) used by a + Contributor and that particular Contributor’s Contribution. + +1.3. “Contribution” + + means Covered Software of a particular Contributor. + +1.4. “Covered Software” + + means Source Code Form to which the initial Contributor has attached the + notice in Exhibit A, the Executable Form of such Source Code Form, and + Modifications of such Source Code Form, in each case including portions + thereof. + +1.5. “Incompatible With Secondary Licenses” + means + + a. that the initial Contributor has attached the notice described in + Exhibit B to the Covered Software; or + + b. that the Covered Software was made available under the terms of version + 1.1 or earlier of the License, but not also under the terms of a + Secondary License. + +1.6. “Executable Form” + + means any form of the work other than Source Code Form. + +1.7. “Larger Work” + + means a work that combines Covered Software with other material, in a + separate file or files, that is not Covered Software. + +1.8. “License” + + means this document. + +1.9. “Licensable” + + means having the right to grant, to the maximum extent possible, whether at + the time of the initial grant or subsequently, any and all of the rights + conveyed by this License. + +1.10. “Modifications” + + means any of the following: + + a. any file in Source Code Form that results from an addition to, deletion + from, or modification of the contents of Covered Software; or + + b. any new file in Source Code Form that contains any Covered Software. + +1.11. “Patent Claims” of a Contributor + + means any patent claim(s), including without limitation, method, process, + and apparatus claims, in any patent Licensable by such Contributor that + would be infringed, but for the grant of the License, by the making, using, + selling, offering for sale, having made, import, or transfer of either its + Contributions or its Contributor Version. + +1.12. “Secondary License” + + means either the GNU General Public License, Version 2.0, the GNU Lesser + General Public License, Version 2.1, the GNU Affero General Public License, + Version 3.0, or any later versions of those licenses. + +1.13. “Source Code Form” + + means the form of the work preferred for making modifications. + +1.14. “You” (or “Your”) + + means an individual or a legal entity exercising rights under this License. + For legal entities, “You” includes any entity that controls, is controlled + by, or is under common control with You. For purposes of this definition, + “control” means (a) the power, direct or indirect, to cause the direction + or management of such entity, whether by contract or otherwise, or (b) + ownership of more than fifty percent (50%) of the outstanding shares or + beneficial ownership of such entity. + + +2. License Grants and Conditions + +2.1. Grants + + Each Contributor hereby grants You a world-wide, royalty-free, + non-exclusive license: + + a. under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or as + part of a Larger Work; and + + b. under Patent Claims of such Contributor to make, use, sell, offer for + sale, have made, import, and otherwise transfer either its Contributions + or its Contributor Version. + +2.2. Effective Date + + The licenses granted in Section 2.1 with respect to any Contribution become + effective for each Contribution on the date the Contributor first + distributes such Contribution. + +2.3. Limitations on Grant Scope + + The licenses granted in this Section 2 are the only rights granted under + this License. No additional rights or licenses will be implied from the + distributionor licensing of Covered Software under this License. + Notwithstanding Section 2.1(b) above, no patent license is granted by a + Contributor: + + a. for any code that a Contributor has removed from Covered Software; or + + b. for infringements caused by: (i) Your and any other third party’s + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + + c. under Patent Claims infringed by Covered Software in the absence of its + Contributions. + + This License does not grant any rights in the trademarks, service marks, or + logos of any Contributor (except as may be necessary to comply with the + notice requirements in Section 3.4). + +2.4. Subsequent Licenses + + No Contributor makes additional grants as a result of Your choice to + distribute the Covered Software under a subsequent version of this License + (see Section 10.2) or under the terms of a Secondary License (if permitted + under the terms of Section 3.3). + +2.5. Representation + + Each Contributor represents that the Contributor believes its Contributions + are its original creation(s) or it has sufficient rights to grant the + rights to its Contributions conveyed by this License. + +2.6. Fair Use + + This License is not intended to limit any rights You have under applicable + copyright doctrines of fair use, fair dealing, or other equivalents. + +2.7. Conditions + + Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted in + Section 2.1. + + +3. Responsibilities + +3.1. Distribution of Source Form + + All distribution of Covered Software in Source Code Form, including any + Modifications that You create or to which You contribute, must be under the + terms of this License. You must inform recipients that the Source Code + Form of the Covered Software is governed by the terms of this License, and + how they can obtain a copy of this License. You may not attempt to alter + or restrict the recipients’ rights in the Source Code Form. + +3.2. Distribution of Executable Form + + If You distribute Covered Software in Executable Form then: + + a. such Covered Software must also be made available in Source Code Form, + as described in Section 3.1, and You must inform recipients of the + Executable Form how they can obtain a copy of such Source Code Form by + reasonable means in a timely manner, at a charge no more than the cost + of distribution to the recipient; and + + b. You may distribute such Executable Form under the terms of this License, + or sublicense it under different terms, provided that the license for + the Executable Form does not attempt to limit or alter the recipients’ + rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + + You may create and distribute a Larger Work under terms of Your choice, + provided that You also comply with the requirements of this License for the + Covered Software. If the Larger Work is a combination of Covered Software + with a work governed by one or more Secondary Licenses, and the Covered + Software is not Incompatible With Secondary Licenses, this License permits + You to additionally distribute such Covered Software under the terms of + such Secondary License(s), so that the recipient of the Larger Work may, at + their option, further distribute the Covered Software under the terms of + either this License or such Secondary License(s). + +3.4. Notices + + You may not remove or alter the substance of any license notices (including + copyright notices, patent notices, disclaimers of warranty, or limitations + of liability) contained within the Source Code Form of the Covered + Software, except that You may alter any license notices to the extent + required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + + You may choose to offer, and to charge a fee for, warranty, support, + indemnity or liability obligations to one or more recipients of Covered + Software. However, You may do so only on Your own behalf, and not on + behalf of any Contributor. You must make it absolutely clear that any such + warranty, support, indemnity, or liability obligation is offered by You + alone, and You hereby agree to indemnify every Contributor for any + liability incurred by such Contributor as a result of warranty, support, + indemnity or liability terms You offer. You may include additional + disclaimers of warranty and limitations of liability specific to any + jurisdiction. + +4. Inability to Comply Due to Statute or Regulation + + If it is impossible for You to comply with any of the terms of this License + with respect to some or all of the Covered Software due to statute, judicial + order, or regulation then You must: (a) comply with the terms of this License + to the maximum extent possible; and (b) describe the limitations and the code + they affect. Such description must be placed in a text file included with + all distributions of the Covered Software under this License. Except to the + extent prohibited by statute or regulation, such description must be + sufficiently detailed for a recipient of ordinary skill to be able to + understand it. + +5. Termination + +5.1. The rights granted under this License will terminate automatically if You + fail to comply with any of its terms. However, if You become compliant, + then the rights granted under this License from a particular Contributor + are reinstated (a) provisionally, unless and until such Contributor + explicitly and finally terminates Your grants, and (b) on an ongoing basis, + if such Contributor fails to notify You of the non-compliance by some + reasonable means prior to 60 days after You have come back into compliance. + Moreover, Your grants from a particular Contributor are reinstated on an + ongoing basis if such Contributor notifies You of the non-compliance by + some reasonable means, this is the first time You have received notice of + non-compliance with this License from such Contributor, and You become + compliant prior to 30 days after Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent + infringement claim (excluding declaratory judgment actions, counter-claims, + and cross-claims) alleging that a Contributor Version directly or + indirectly infringes any patent, then the rights granted to You by any and + all Contributors for the Covered Software under Section 2.1 of this License + shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all end user + license agreements (excluding distributors and resellers) which have been + validly granted by You or Your distributors under this License prior to + termination shall survive termination. + +6. Disclaimer of Warranty + + Covered Software is provided under this License on an “as is” basis, + without warranty of any kind, either expressed, implied, or statutory, + including, without limitation, warranties that the Covered Software is free + of defects, merchantable, fit for a particular purpose or non-infringing. + The entire risk as to the quality and performance of the Covered Software + is with You. Should any Covered Software prove defective in any respect, + You (not any Contributor) assume the cost of any necessary servicing, + repair, or correction. This disclaimer of warranty constitutes an + essential part of this License. No use of any Covered Software is + authorized under this License except under this disclaimer. + +7. Limitation of Liability + + Under no circumstances and under no legal theory, whether tort (including + negligence), contract, or otherwise, shall any Contributor, or anyone who + distributes Covered Software as permitted above, be liable to You for any + direct, indirect, special, incidental, or consequential damages of any + character including, without limitation, damages for lost profits, loss of + goodwill, work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses, even if such party shall have been + informed of the possibility of such damages. This limitation of liability + shall not apply to liability for death or personal injury resulting from + such party’s negligence to the extent applicable law prohibits such + limitation. Some jurisdictions do not allow the exclusion or limitation of + incidental or consequential damages, so this exclusion and limitation may + not apply to You. + +8. Litigation + + Any litigation relating to this License may be brought only in the courts + of a jurisdiction where the defendant maintains its principal place of + business and such litigation shall be governed by laws of that + jurisdiction, without reference to its conflict-of-law provisions. Nothing + in this Section shall prevent a party’s ability to bring cross-claims or + counter-claims. + +9. Miscellaneous + + This License represents the complete agreement concerning the subject + matter hereof. If any provision of this License is held to be + unenforceable, such provision shall be reformed only to the extent + necessary to make it enforceable. Any law or regulation which provides + that the language of a contract shall be construed against the drafter + shall not be used to construe this License against a Contributor. + + +10. Versions of the License + +10.1. New Versions + + Mozilla Foundation is the license steward. Except as provided in Section + 10.3, no one other than the license steward has the right to modify or + publish new versions of this License. Each version will be given a + distinguishing version number. + +10.2. Effect of New Versions + + You may distribute the Covered Software under the terms of the version of + the License under which You originally received the Covered Software, or + under the terms of any subsequent version published by the license + steward. + +10.3. Modified Versions + + If you create software not governed by this License, and you want to create + a new license for such software, you may create and use a modified version + of this License if you rename the license and remove any references to the + name of the license steward (except to note that such modified license + differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary Licenses + + If You choose to distribute Source Code Form that is Incompatible With + Secondary Licenses under the terms of this version of the License, the + notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice + + This Source Code Form is subject to the + terms of the Mozilla Public License, v. + 2.0. If a copy of the MPL was not + distributed with this file, You can + obtain one at + http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular file, then +You may include the notice in a location (such as a LICENSE file in a relevant +directory) where a recipient would be likely to look for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - “Incompatible With Secondary Licenses” Notice + + This Source Code Form is “Incompatible + With Secondary Licenses”, as defined by + the Mozilla Public License, v. 2.0. +
+ Setup.hs view
@@ -0,0 +1,2 @@+main = defaultMain +
+ reorderable.cabal view
@@ -0,0 +1,211 @@+Name: reorderable+Version: 0.3+Cabal-Version: >= 1.2+Build-Type: Simple+License: OtherLicense+License-File: LICENSE+Copyright: (c) 2013, Alex Cole+Author: Alex Cole <haskell@y-less.com>+Maintainer: Alex Cole <haskell@y-less.com>+Stability: Experimental+Synopsis: Define compound types that do not depend on member order.+Category: Type System, Data++Description:+ + * Introduction.+ + The pair `(Int, Float)' is entirely distinct from the pair `(Float, Int)'+ and trying to use one in place of the other will give a type error.+ This is often, but not always, desired.+ + * Module.+ + This module provides more flexible sum and product types that do not enforce+ a single order on their elements. This does introduce some necessary+ restrictions, for example only one instance of any type can appear in+ any given collection of types. Additionally, all types that are to be+ used in one of these flexible containers must be pre-defined as+ `reorderable':+ + @+ data MyType1 = MyType1 Int+ data MyType2 = MyType2 Float+ data MyType3 = MyType3 Bool+ data MyType3 = MyType4 String+ + reorderable ''MyType1+ reorderable ''MyType2+ reorderable ''MyType3+ reorderable ''MyType4+ @+ + That will, using /Template Haskell/, generate all the required instances to+ make those types usable as reorderable types within unordered+ containers. Following that, all the declarations below are valid:+ + @+ type Reordered1A = ReorderableEnd :*: MyType2 :*: MyType1+ type Reordered1B = ReorderableEnd :*: MyType1 :*: MyType2+ type Reordered2 = Reordered1A :*: MyType3+ type Reordered3 = ReorderableEnd :*: MyType4 :*: Reordered1B+ @+ + Types `Reordered1A' and `Reordered1B' are in fact now identical. This does+ introduce a third limitation of the library I have been unable to lift -+ the use of `ReorderableEnd' as a sentinel in all reorderable containers.+ + It may be the case that `Type1' and `Type2' can be used together, as can+ `Type3' and `Type4', but the two sets of types can not be used in a+ container together. These are /groups/ of types:+ + @+ reorderableGroup [''MyType1, ''MyType2]+ reorderableGroup [''MyType3, ''MyType4]+ @+ + The groups can overlap:+ + @+ reorderableGroup [''MyType1, ''MyType2]+ reorderableGroup [''MyType1, ''MyType3, ''MyType4]+ @+ + But this may cause some \"leakage\" where types from two different groups+ (for example `MyType2' and `MyType4') end up in the same container,+ attached via common types.+ + * Generation.+ + For each type `X' for which `reorderable' (or equivalent) is called, the+ following functions are generated (where `X' is the type name):+ + @+ addSumX :: (x :>: s) => s -> s :+: x+ setSumX :: (x :<: s) => x -> s -> s+ getSumX :: (x :<: s) => s -> Maybe x+ + addProductX :: (x :~: s) => x -> s -> s :*: x+ setProductX :: (x :?: s) => x -> s -> s+ getProductX :: (x :?: s) => s -> x+ + removeProductX :: (x :?: s) => s -> s :-: x+ @+ + ** Notes on the syntax:+ + * `:<:' Is read as \"Is member of sum type\".+ * `:>:' Is read as \"Is not member of sum type\".+ * `:+:' Is read as \"Plus\".+ + * `:?:' Is read as \"Is member of product type\".+ * `:~:' Is read as \"Is not member of product type\".+ * `:*:' Is read as \"Product\".+ * `:-:' Is read as \"Remove\".+ + ** Notes on the functions:+ + * `addSumX' Adds the TYPE `x' to the given signature, and correctly+ re-wraps the contained data to reflect this new structure. It does+ not add any data in to the structure itself because only one item+ may exist in the structure, and that item is already there.+ + * `setSumX' Changes what data is currently stored in the sum. For a+ given concrete sum type `S', this can be called as:+ `setSumX x (undefined :: S)'. An alternative version is simply:+ `setSumType (undefined :: S) x', in which `X :<: S'. This is+ equivalent to the original `inj' function from `Data Types \'a la+ Carte', but has an explicit type proxy.+ + * `getSumX' Returns the data of type `Just X' IF it is the data+ currently being stored within the sum, otherwise it returns+ `Nothing'. This is equivalent to the original `prj' function from+ `Data Types \'a la Carte'.+ + * `addProductX' Adds data of type `X' to an existing product type that+ does not yet contain any data of that type.+ + * `setProductX' Sets the data of type `X' in a product type that already+ contains data of that type.+ + * `getProductX' Gets the data of type `X' from a product type that+ contains data of that type.+ + * `removeProductX' Removes data of type `X' from a product type that+ contains data of that type, and rewraps the resulting information to+ remove `X' from the product's type. There is no `removeSumX'+ function because the result is empty if the stored data is not of+ the type being removed.+ + * Generators.+ + In addition to being able to control for which types code is generated, you+ can control what code is generated for them through `reorderer's. Note+ that the default code listed above is ALWAYS generated, you can+ currently only ADD to the generation code. The simplest way to explain+ this is through an example:+ + @+ class ReorderableSum a++ [reorderer|ReorderableSum+ addSum??? :: (OutSumType without ???) => without -> AddSumType without ???+ addSum??? without = addSumType without (undefined :: ???)+ + setSum??? :: (InSumType with ???) => ??? -> with -> with+ setSum??? a b = setSumType b a+ + getSum??? :: (InSumType with ???) => with -> Maybe ???+ getSum??? with = getSumType with (undefined :: ???)+ |]+ @+ + The code above is exactly the code used to generate the sum type functions+ documented above. The internal class names are used in place of the+ type operator synonyms for simplicity. `???' is used as a placeholder+ to be replaced by the unqualified type names from every instance of+ `reorderable' in the code. The empty class `ReorderableSum' is a+ unique name with a single type parameter, passed as the first symbol+ to the reorderer. An instance of this class is generated for each+ reorderable type, to track for which types this reorderer has already+ been generated (using `reify'). The simple reason for this is that+ placing the same type in two `reorderableGroup's will, without that+ check, attempt to instantiate this code twice and thus give errors.+ + What can be done within generators is very constrained. For one thing, the+ parameter `a' to `ReorderableSum' currently MUST have kind `*', so any+ reorderable types may not have type parameters themselves (unless a new+ generator is written for exactly that type). Additionally, the+ placeholder `???' in no way accounts for complex names - it is purely a+ text-based replacement, so trying to create a reorderable ``Maybe Int''+ type will result in the illegal:+ + @+ addSumMaybe Int :: ...+ @+ + Finally, this code is processed with \"haskell-src-meta\", and so any code+ must be parsable with that code. One lifting of this restriction is+ that reorderers may additionally contain type family declarations, which+ are by default not supported by that library (despite having issued a+ pull request many months ago).++Library+ Exposed-Modules:+ Data.Types.Reorder,+ Data.Types.Reorder.TH,+ Data.Types.Reorder.Sum,+ Data.Types.Reorder.Base,+ Data.Types.Reorder.Quoter,+ Data.Types.Reorder.Product,+ Data.Types.Reorder.Instances+ + Build-Depends:+ base >= 4.0.0.0 && < 5,+ template-haskell >= 2.4.0.0,+ haskell-src-meta >= 0.6.0.4,+ haskell-src-exts >= 1.14 && < 1.15,+ constraints >= 0.1+ + Hs-Source-Dirs: src+
+ src/Data/Types/Reorder.hs view
@@ -0,0 +1,52 @@+{- + Copyright (c) 2013, Alex Cole + + This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at http://mozilla.org/MPL/2.0/. +-} + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE QuasiQuotes #-} + +module Data.Types.Reorder ( + module Data.Types.Reorder.Base, + module Data.Types.Reorder.Product, + module Data.Types.Reorder.Sum, + reorderableGroup, + debugProductType, + reorderable, + reorderer + ) where + +-- Core type classes on which the reorderable types are based. +import Data.Types.Reorder.Base + +-- Generate the instances for all reorderable types to interact with our +-- sentinel type. +import Data.Types.Reorder.Quoter + +-- Generate code for creating sum and product types. +import Data.Types.Reorder.Sum +import Data.Types.Reorder.Product + +-- The code tha actually declares a new type as usable in a reorderable +-- container. +import Data.Types.Reorder.TH (reorderable, reorderableGroup) + +-- Show, Read, and Eq instances for Product and Sum types. +import Data.Types.Reorder.Instances + +class ReorderableEndDone a + +[reorderer|ReorderableEndDone + -- Two things the same are always the same. + type instance TypeOrder ??? ??? = TypeOrder_Same + -- "ReorderableEnd" always comes after everything else - that is the nature + -- of an "End". Were this not stated as a special case, it would result in + -- this type being ordered alphabetically instead. + type instance TypeOrder ReorderableEnd ??? = TypeOrder_Lower + type instance TypeOrder ??? ReorderableEnd = TypeOrder_Higher +|] +
+ src/Data/Types/Reorder/Base.hs view
@@ -0,0 +1,52 @@+{- + Copyright (c) 2013, Alex Cole + + This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at http://mozilla.org/MPL/2.0/. +-} + +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE EmptyDataDecls #-} +{- # LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +module Data.Types.Reorder.Base where + +import Language.Haskell.TH + +import GHC.TypeLits +import Data.Constraint + +-- This is simply a placeholder to mark the end of our dynamic data type. +data ReorderableEnd +reorderableEnd :: ReorderableEnd +reorderableEnd = undefined + +-- This determines the relative ordering of two types. Generally the first +-- type given is either a concrete type or a container, and the second type is +-- only a concrete type. If it isn't, then "TypeOrder_Composition" is used to +-- indicate the special case and recurse. +data TypeOrder_Lower +data TypeOrder_Higher +data TypeOrder_Same +data TypeOrder_Composition +data TypeOrder_End + +type family TypeOrder t0 t1 +type instance TypeOrder ReorderableEnd ReorderableEnd = TypeOrder_End + +-- | Get the order of a new type relative to an existing collection of types, +-- i.e. extract the top type in the collection and compare to that. The +-- "GetReorderableChild" type doesn't actually need the last "x" type parameter. +type family GetReorderableChild (container :: * -> * -> *) a x +type instance GetReorderableChild container (container l r) x = r +type instance GetReorderableChild container ReorderableEnd x = ReorderableEnd + +-- | Pass the container so we can pattern match on it at the type level. +type GetTypeOrder container a t = TypeOrder (GetReorderableChild container a t) t + +class ReorderableInstance (a :: * -> Constraint) (n :: Nat) (r :: Symbol) | a n -> r +
+ src/Data/Types/Reorder/Instances.hs view
@@ -0,0 +1,111 @@+{- + Copyright (c) 2013, Alex Cole + + This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at http://mozilla.org/MPL/2.0/. +-} + +{-# LANGUAGE MultiParamTypeClasses #-} +{- # LANGUAGE OverlappingInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Types.Reorder.Instances ( + debugProductType + ) where + +import Data.Types.Reorder.Base +import Data.Types.Reorder.Product +import Data.Types.Reorder.Sum + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +instance (Eq a, Eq b) => Eq (ProductType a b) where + ProductType l0 l1 == ProductType r0 r1 = l0 == r0 && l1 == r1 + ProductType l0 l1 /= ProductType r0 r1 = l0 /= r0 || l1 /= r1 + +instance (Eq b) => Eq (ProductType ReorderableEnd b) where + ProductType _ l1 == ProductType _ r1 = l1 == r1 + ProductType _ l1 /= ProductType _ r1 = l1 /= r1 + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +sep c = (c :) . (' ' :) + +class ShowProductType x y where + showProductType :: ProductType x y -> ShowS + debugProductType :: ProductType x y -> String + +-- For things that don't use "ReorderableEnd". +instance (Show x, Show y) => ShowProductType x y where + showProductType (ProductType l r) = shows l . sep ',' . shows r + debugProductType (ProductType l r) = "<(END), " ++ show l ++ ", " ++ show r ++ ">" + +instance (ShowProductType a b, Show y) => ShowProductType (ProductType a b) y where + showProductType (ProductType l r) = showProductType l . sep ',' . shows r + debugProductType (ProductType l r) = "<" ++ debugProductType l ++ ", " ++ show r ++ ">" + +-- Don't show the type sentinel ever. +instance (Show y) => ShowProductType ReorderableEnd y where + showProductType (ProductType _ r) = shows r + debugProductType (ProductType _ r) = "<(END), " ++ show r ++ ">" + +instance (ShowProductType a b) => Show (ProductType a b) where + -- Ignore precedence, we always use angle brackets here. + showsPrec _ x = ('<' :) . showProductType x . ('>' :) + show x = '<' : showProductType x ">" + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +instance (Eq a, Eq b) => Eq (SumType a b) where + SumTypeLeft l0 == SumTypeLeft l1 = l0 == l1 + SumTypeRight r0 == SumTypeRight r1 = r0 == r1 + _ == _ = False + SumTypeLeft l0 /= SumTypeLeft l1 = l0 /= l1 + SumTypeRight r0 /= SumTypeRight r1 = r0 /= r1 + _ /= _ = True + +instance (Eq b) => Eq (SumType ReorderableEnd b) where + SumTypeRight r0 == SumTypeRight r1 = r0 == r1 + _ == _ = False + SumTypeRight r0 /= SumTypeRight r1 = r0 /= r1 + _ /= _ = True + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- I did write a VASTLY more generic version of this class that could handle any +-- arbitrary tree of sum types (growing left and right), rather than just the +-- nicely ordered types created by this code. +class ShowSumType x y where + showSumType :: SumType x y -> ShowS + +instance (ShowSumType a b, Show y) => ShowSumType (SumType a b) y where + showSumType (SumTypeLeft l) = ('<' :) . showSumType l + showSumType (SumTypeRight r) = ('>' :) . showsPrec 0 r + +-- Don't show the type sentinel ever. +instance (Show y) => ShowSumType ReorderableEnd y where + showSumType (SumTypeLeft _) = ('-' :) + showSumType (SumTypeRight r) = ('>' :) . showsPrec 0 r + +instance (ShowSumType l r) => Show (SumType l r) where + showsPrec _ a = ('(' :) . showSumType a . (')' :) + show a = '(' : showSumType a ")" + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +instance (Read a, Read b) => Read (SumType a b) where + readsPrec prec str@(h : rest) + | h == '(' = readParen True (readsPrec prec) str + | h == '<' = [(SumTypeLeft left, leftRem)] + | h == '>' = [(SumTypeRight rite, riteRem)] + | otherwise = [] + where + ((left, leftRem) : _) = readsPrec prec rest + ((rite, riteRem) : _) = readsPrec prec rest +
+ src/Data/Types/Reorder/Product.hs view
@@ -0,0 +1,236 @@+{- + Copyright (c) 2013, Alex Cole + + This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at http://mozilla.org/MPL/2.0/. +-} + +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE QuasiQuotes #-} + +module Data.Types.Reorder.Product ( + removeProductType, + addProductType, + setProductType, + getProductType, + emptyProduct, + ProductType(..), + AddProductType, + (:*:), + RemoveProductType, + (:-:), + OutProductType, + (:~:), + InProductType, + (:?:) + ) where + +import Data.Types.Reorder.Base +import Data.Types.Reorder.Quoter +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (nameBase) + +data ProductType a b = ProductType a b +type ProductTypeOrder a t = GetTypeOrder ProductType a t + +emptyProduct = reorderableEnd + +type instance TypeOrder x (ProductType l r) = TypeOrder_Composition + +makeProductOrderingFlag :: without -> t -> ProductTypeOrder without t +makeProductOrderingFlag _ _ = undefined + +-------------------------------------------------------------------------------- + +class + AddProductTypeClass flag without t with | flag without t -> with + where + type AddProductType' flag without t + addProductType' :: flag -> without -> t -> with + +-- | If we end up with two `ReorderableEnd's being added together just return +-- one. This is generally only encountered when combining two product types. +instance + AddProductTypeClass TypeOrder_End ReorderableEnd ReorderableEnd ReorderableEnd + where + type AddProductType' TypeOrder_End ReorderableEnd ReorderableEnd = ReorderableEnd + addProductType' _ _ _ = reorderableEnd + +-- | Compose two product types in to one large one recursively. +instance + (AddProductTypeClass (ProductTypeOrder without r) without r with', + AddProductTypeClass (ProductTypeOrder with' l) with' l with) => + AddProductTypeClass TypeOrder_Composition without (ProductType l r) with + where + type AddProductType' TypeOrder_Composition without (ProductType l r) = + AddProductType' + (ProductTypeOrder (AddProductType' (ProductTypeOrder without r) without r) l) + (AddProductType' (ProductTypeOrder without r) without r) l + addProductType' _ without (ProductType l r) = addProductType (addProductType without r) l + +-- | Add a type to the end of the current product. +instance + AddProductTypeClass TypeOrder_Lower without t (ProductType without t) + where + type AddProductType' TypeOrder_Lower without t = ProductType without t + addProductType' _ = ProductType + +-- | Add a type deeper in to the current product. +instance + (AddProductTypeClass (ProductTypeOrder l t) l t with) => + AddProductTypeClass TypeOrder_Higher (ProductType l r) t (ProductType with r) + where + type AddProductType' TypeOrder_Higher (ProductType l r) t = ProductType (AddProductType' (ProductTypeOrder l t) l t) r + addProductType' _ (ProductType l r) t = ProductType (addProductType l t) r + +addProductType w t = addProductType' (makeProductOrderingFlag w t) w t + +-- | Add type. +type AddProductType without t = AddProductType' (ProductTypeOrder without t) without t +type (:*:) without t = AddProductType without t -- Can't curry types :(. + +-- | Doesn't have type. +type OutProductType without t = AddProductTypeClass (ProductTypeOrder without t) without t (AddProductType without t) +type (:~:) t without = OutProductType without t + +-------------------------------------------------------------------------------- + +class + HasProductTypeClass flag with t without | flag with t -> without + where + type RemoveProductType' flag with t + removeProductType' :: flag -> with -> t -> without + + setProductType' :: flag -> with -> t -> with + getProductType' :: flag -> with -> t -> t + +-- | If we end up with two `ReorderableEnd's being added together just return +-- one. This is generally only encountered when combining two product types. +instance + HasProductTypeClass TypeOrder_End ReorderableEnd ReorderableEnd ReorderableEnd + where + type RemoveProductType' TypeOrder_End ReorderableEnd ReorderableEnd = ReorderableEnd + removeProductType' _ _ _ = reorderableEnd + + setProductType' _ _ _ = reorderableEnd + getProductType' _ _ _ = reorderableEnd + +-- | Compose two product types in to one large one recursively. +instance + -- This would not be required if the definition of `getProductType' + -- could use @getProductType with' l@ where @with'@ is the remaining + -- types from @getProductType with r@ after getting @r@, in which case + -- the other two constraints would suffice. Unfortunately we can't, but + -- this constraint encompasses the other two, so its all good. + (HasProductTypeClass (ProductTypeOrder with l) with l without_, + -- These are required recursive constraints. + HasProductTypeClass (ProductTypeOrder with r) with r without', + HasProductTypeClass (ProductTypeOrder without' l) without' l without) => + HasProductTypeClass TypeOrder_Composition with (ProductType l r) without + where + type RemoveProductType' TypeOrder_Composition with (ProductType l r) = + RemoveProductType' + (ProductTypeOrder (RemoveProductType' (ProductTypeOrder with r) with r) l) + (RemoveProductType' (ProductTypeOrder with r) with r) l + removeProductType' _ with (ProductType l r) = removeProductType (removeProductType with r) l + + setProductType' _ with (ProductType l r) = setProductType (setProductType with r) l + getProductType' _ with (ProductType l r) = ProductType (getProductType with l) (getProductType with r) + +instance + HasProductTypeClass TypeOrder_Same (ProductType without t) t without + where + type RemoveProductType' TypeOrder_Same (ProductType without t) t = without + removeProductType' _ (ProductType l _) _ = l + + setProductType' _ (ProductType l _) x = ProductType l x + getProductType' _ (ProductType _ r) _ = r + +instance + (HasProductTypeClass (ProductTypeOrder l t) l t without) => + HasProductTypeClass TypeOrder_Higher (ProductType l r) t (ProductType without r) + where + type RemoveProductType' TypeOrder_Higher (ProductType l r) t = ProductType (RemoveProductType' (ProductTypeOrder l t) l t) r + removeProductType' _ (ProductType l r) t = ProductType (removeProductType l t) r + + setProductType' _ (ProductType l r) t = ProductType (setProductType l t) r + getProductType' _ (ProductType l _) t = getProductType l t + +removeProductType w t = removeProductType' (makeProductOrderingFlag w t) w t +setProductType w t = setProductType' (makeProductOrderingFlag w t) w t +getProductType w t = getProductType' (makeProductOrderingFlag w t) w t + +-- | Remove type. +type RemoveProductType with t = RemoveProductType' (ProductTypeOrder with t) with t +type (:-:) with t = RemoveProductType with t + +-- | Has type. +type InProductType with t = HasProductTypeClass (ProductTypeOrder with t) with t (RemoveProductType with t) +type (:?:) t with = InProductType with t + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- This code is the generator for "ProductType" instance generation. + +-- productInstanceGenerator :: Name -> [Dec] +-- productInstanceGenerator new = buildProductInstances + -- where + -- buildProductInstances = [ + -- SigD delP (ForallT [PlainTV with] [_HasProductType [VarT with, _T]] (app2 ArrowT (VarT with) (app2 (ConT $ mkName "RemoveProductType") (VarT with) _T))), + -- FunD delP [Clause [VarP with] (NormalB (AppE (AppE (VarE $ mkName "removeProductType") (VarE with)) (SigE undef _T))) []], + + -- SigD addP (ForallT [PlainTV without] [ClassP (mkName "OutProductType") [VarT without, _T]] (app2 ArrowT (VarT without) (app2 ArrowT _T (app2 (ConT $ mkName "AddProductType") (VarT without) _T)))), + -- ValD (VarP addP) (NormalB (VarE $ mkName "addProductType")) [], + + -- SigD setP (ForallT [PlainTV with] [_HasProductType [VarT with, _T]] (app2 ArrowT (VarT with) (app2 ArrowT _T (VarT with)))), + -- ValD (VarP setP) (NormalB (VarE $ mkName "setProductType")) [], + + -- SigD getP (ForallT [PlainTV with] [_HasProductType [VarT with, _T]] (app2 ArrowT (VarT with) _T)), + -- FunD getP [Clause [VarP with] (NormalB (AppE (AppE (VarE $ mkName "getProductType") (VarE with)) (SigE undef _T))) []] + -- ] + + -- -- Helper function. + -- app2 a b c = AppT (AppT a b) c + -- t = nameBase new + + -- -- Mostly helpful names. + -- undef = VarE $ mkName "undefined" + + -- with = mkName "with" + -- without = mkName "without" + + -- _T = ConT new + + -- -- "Product" helpful names. + -- _HasProductType = ClassP $ mkName "InProductType" + + -- setP = mkName $ "setProduct" ++ t + -- getP = mkName $ "getProduct" ++ t + -- addP = mkName $ "addProduct" ++ t + -- delP = mkName $ "removeProduct" ++ t + +class ReorderableProduct a + +[reorderer|ReorderableProduct + removeProduct??? :: (InProductType with ???) => with -> RemoveProductType with ??? + removeProduct??? with = removeProductType with (undefined :: ???) + + addProduct??? :: (OutProductType without ???) => ??? -> without -> AddProductType without ??? + addProduct??? a b = addProductType b a + + setProduct??? :: (InProductType with ???) => ??? -> with -> with + setProduct??? a b = setProductType b a + + getProduct??? :: (InProductType with ???) => with -> ??? + getProduct??? with = getProductType with (undefined :: ???) +|] +
+ src/Data/Types/Reorder/Quoter.hs view
@@ -0,0 +1,74 @@+{- + Copyright (c) 2013, Alex Cole + + This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at http://mozilla.org/MPL/2.0/. +-} + +{-# LANGUAGE TemplateHaskell #-} + +module Data.Types.Reorder.Quoter ( + reorderer + ) where + +import Data.Maybe (mapMaybe) + +import Data.Types.Reorder.Base + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +reorderer :: QuasiQuoter +reorderer = QuasiQuoter { + quoteExp = error "quoteExp is not defined for \"reorder\".", + quotePat = error "quoteExp is not defined for \"reorder\".", + quoteType = error "quoteExp is not defined for \"reorder\".", + quoteDec = + let + appT3 c x y z = AppT (AppT (AppT c x) y) z + numTyLit = LitT . NumTyLit + strTyLit = LitT . StrTyLit + in + return . (\ (t : ds) -> zipWith + (\ num d -> InstanceD [] (appT3 (ConT ''ReorderableInstance) (ConT $ mkName t) (numTyLit num) (strTyLit d)) []) + [0 .. ] ds + ) . mapMaybe trim . map removeLineComments . lines . removeBlockComments + } + +trim :: String -> Maybe String +trim str + -- This pattern appears to miss the case of just one character, which is + -- less than ' ', but that case cannot happen because the "dropWhile" + -- will remove that one character, leaving nothing. + | rem == [] = Nothing + | last rem <= ' ' = Just $ init rem + | otherwise = Just rem + where + rem = dropWhile (<= ' ') str + +-- These functions are not perfect. I don't know if it would be better to just +-- leave haskell-src-meta to sort out the comments. For example, this will give +-- the wrong result: +-- +-- i |-- 7 +-- +-- Here "|--" is an operator, whereas this will strip off everything after "|" +-- as a comment. +removeBlockComments = findStart + where + findStart [] = [] + findStart ('{' : '-' : rest) = findStart (findEnd rest) + findStart (r : rest) = r : findStart rest + findEnd [] = error "Invalid comment." + findEnd ('-' : '}' : rest) = rest + findEnd ('{' : '-' : rest) = findEnd (findEnd rest) + findEnd (r : rest) = findEnd rest + +removeLineComments [] = [] +removeLineComments ('-' : '-' : _) = [] +removeLineComments (r : rest) = r : removeLineComments rest +
+ src/Data/Types/Reorder/Sum.hs view
@@ -0,0 +1,166 @@+{- + Copyright (c) 2013, Alex Cole + + This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at http://mozilla.org/MPL/2.0/. +-} + +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE QuasiQuotes #-} + +module Data.Types.Reorder.Sum ( + addSumType, + setSumType, + getSumType, + emptySum, + SumType(..), + AddSumType, + (:+:), + OutSumType, + (:>:), + InSumType, + (:<:) + ) where + +import Data.Types.Reorder.Base +import Data.Types.Reorder.Quoter +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (nameBase) + +data SumType a b = SumTypeLeft a | SumTypeRight b +type SumTypeOrder a t = GetTypeOrder SumType a t + +emptySum = reorderableEnd + +type instance TypeOrder x (SumType l r) = TypeOrder_Composition + +makeSumOrderingFlag :: without -> t -> SumTypeOrder without t +makeSumOrderingFlag _ _ = undefined + +-------------------------------------------------------------------------------- + +class + AddSumTypeClass flag without t with | flag without t -> with + where + type AddSumType' flag without t + + addSumType' :: flag -> without -> t -> with + +-- | If we end up with two `ReorderableEnd's being added together just return +-- one. This is generally only encountered when combining two Sum types. +instance + AddSumTypeClass TypeOrder_End ReorderableEnd ReorderableEnd ReorderableEnd + where + type AddSumType' TypeOrder_End ReorderableEnd ReorderableEnd = ReorderableEnd + + addSumType' _ _ _ = reorderableEnd + +-- | Compose two Sum types in to one large one recursively. +instance + (AddSumTypeClass (SumTypeOrder without r) without r with', + AddSumTypeClass (SumTypeOrder with' l) with' l with) => + AddSumTypeClass TypeOrder_Composition without (SumType l r) with + where + type AddSumType' TypeOrder_Composition without (SumType l r) = + AddSumType' + (SumTypeOrder (AddSumType' (SumTypeOrder without r) without r) l) + (AddSumType' (SumTypeOrder without r) without r) l + + addSumType' _ w _ = undefined + +-- | Add a type to the end of the current Sum. +instance + AddSumTypeClass TypeOrder_Lower without t (SumType without t) + where + type AddSumType' TypeOrder_Lower without t = SumType without t + + addSumType' _ x _ = SumTypeLeft x + +-- | Add a type deeper in to the current Sum. +instance + (AddSumTypeClass (SumTypeOrder l t) l t with) => + AddSumTypeClass TypeOrder_Higher (SumType l r) t (SumType with r) + where + type AddSumType' TypeOrder_Higher (SumType l r) t = SumType (AddSumType' (SumTypeOrder l t) l t) r + + addSumType' _ (SumTypeLeft l) t = SumTypeLeft (addSumType l t) + addSumType' _ (SumTypeRight r) _ = SumTypeRight r + -- -- The unwrap/wrap is required to change the constructor's type. + +addSumType w t = addSumType' (makeSumOrderingFlag w t) w t + +-- | Add type. +type AddSumType without t = AddSumType' (SumTypeOrder without t) without t +type (:+:) without t = AddSumType without t -- Can't curry types :(. + +-- | Doesn't have type. +type OutSumType without t = AddSumTypeClass (SumTypeOrder without t) without t (AddSumType without t) +type (:>:) t without = OutSumType without t + +-------------------------------------------------------------------------------- + +class + HasSumTypeClass flag with t + where + setSumType' :: flag -> with -> t -> with + getSumType' :: flag -> with -> t -> Maybe t + +-- | If we end up with two `ReorderableEnd's being added together just return +-- one. This is generally only encountered when combining two Sum types. +instance + HasSumTypeClass TypeOrder_End ReorderableEnd ReorderableEnd + where + setSumType' _ _ _ = reorderableEnd + getSumType' _ _ _ = Nothing + +instance + HasSumTypeClass TypeOrder_Same (SumType without t) t + where + setSumType' _ _ x = SumTypeRight x + getSumType' _ (SumTypeLeft _) _ = Nothing + getSumType' _ (SumTypeRight r) _ = Just r + +instance + (HasSumTypeClass (SumTypeOrder l t) l t) => + HasSumTypeClass TypeOrder_Higher (SumType l r) t + where + setSumType' _ _ x = SumTypeLeft (setSumType (undefined :: l) x) + getSumType' _ (SumTypeLeft l) x = getSumType l x + getSumType' _ (SumTypeRight _) _ = Nothing + +setSumType w t = setSumType' (makeSumOrderingFlag w t) w t +getSumType w t = getSumType' (makeSumOrderingFlag w t) w t + +-- | Has type. +type InSumType with t = HasSumTypeClass (SumTypeOrder with t) with t + +type (:<:) t with = InSumType with t + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- This code is the generator for "SumType" instance generation. +class ReorderableSum a + +[reorderer|ReorderableSum + addSum??? :: (OutSumType without ???) => without -> AddSumType without ??? + addSum??? without = addSumType without (undefined :: ???) + + -- createSum??? :: (InSumType with ???) => ??? -> with + -- createSum??? = setSumType (undefined :: with) + + setSum??? :: (InSumType with ???) => ??? -> with -> with + setSum??? a b = setSumType b a + + getSum??? :: (InSumType with ???) => with -> Maybe ??? + getSum??? with = getSumType with (undefined :: ???) +|] +
+ src/Data/Types/Reorder/TH.hs view
@@ -0,0 +1,278 @@+{- + Copyright (c) 2013, Alex Cole + + This Source Code Form is subject to the terms of the Mozilla Public License, + v. 2.0. If a copy of the MPL was not distributed with this file, You can + obtain one at http://mozilla.org/MPL/2.0/. +-} + +{-# LANGUAGE TemplateHaskell #-} + +module Data.Types.Reorder.TH ( + reorderable, + reorderableGroup + ) where + +import Data.Types.Reorder.Base +import Data.Types.Reorder.Quoter + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote + +import Data.Maybe (mapMaybe) +import Data.List (nub) + +import Language.Haskell.Exts.Parser +import Language.Haskell.Exts.Extension +import qualified Language.Haskell.Exts.Syntax as Hs + +import Language.Haskell.Meta.Parse +import Language.Haskell.Meta.Syntax.Translate +-- import qualified Language.Haskell.Exts.Annotated.Fixity as Fix + +-- Type class on which to store types that are declared using "reorderable" +-- instead of "reorderableGroup", i.e. types that need interaction code +-- generating for new reorderable types. +class ReorderableGlobalGroup a + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- | Takes a type name, i.e. @reorderable ''IP@. +reorderable :: Name -> Q [Dec] +reorderable new + | new == ''ReorderableEnd = return [] -- Deny this type. + | otherwise = generateCoreCode new `cat` ( + getAllGlobals >>= (\ old -> concatMapM (generatePairCode new) old `cat` ( + if new `elem` old + then return [] + else return [InstanceD [] (AppT (ConT ''ReorderableGlobalGroup) (ConT new)) []]))) + where + getAllGlobals = reify ''ReorderableGlobalGroup >>= (\ (ClassI _ instances) -> return $ + map (\ (InstanceD _ (AppT _ (ConT t)) _) -> t) instances) + +-- | Takes a list of names, and generates pair instances for them all. +-- +-- > reorderableGroup [''IP, ''TIC, ''RT] +-- +reorderableGroup new' = concatMapM generateCoreCode new `cat` genPairs new + where + -- Filter all types that are NOT "ReorderableEnd", and remove any + -- duplicates. The code above will not generate any code in the case of + -- an empty list, so don't check for that case explicitly as it is by + -- far an uncommon case, thus a waste of time in the common case. + new = nub $ filter (not . (==) ''ReorderableEnd) new' + -- For each element in the array, generate it paired with all LATER + -- items. We know that the array has all duplicates removed, so as long + -- as we ensure that when generating a pair we generated in both + -- directions (i.e. "TypeOrder a b" and "TypeOrder b a"), this will + -- generate all combinations from the array. + genPairs [] = return [] + genPairs (x : []) = return [] + genPairs (x : xs) = concatMapM (generatePairCode x) xs `cat` genPairs xs + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- | This code generates the code required to compare two reorderable types. It +-- generates two instances for every valid combination of reorderable types, it +-- then stores all the generated combinations in case one comes up again. E.g: +-- +-- > reorderableGroup [''Type1, ''Type2, ''Type3] +-- > reorderableGroup [''Type1, ''Type2, ''Type4] +-- +-- This will not generate a pair for @(''Type3, ''Type4)@, and will also +-- remember that it has already generated a pair for @(''Type1, ''Type2)@ when +-- the second group comes to be compiled. +generatePairCode :: Name -> Name -> Q [Dec] +generatePairCode new old = getAllPairs >>= + (\ p -> return $ generatePairCode' new old p ++ generatePairCode' old new p) + where + -- Find all existing type pairs. + getAllPairs = reify ''TypeOrder >>= (\ (FamilyI _ instances) -> return $ + mapMaybe exTypes instances) + -- Extract the two types. + exTypes (TySynInstD _ [ConT a, ConT b] _) = Just (a, b) + -- exTypes (TySynInstD _ [] _) = error "0" + -- exTypes (TySynInstD _ [_] _) = error "1" + -- exTypes (TySynInstD a xs b) = error $ show a ++ ", " ++ show xs ++ ", " ++ show b + exTypes _ = Nothing + -- Generate one pair one way around. + generatePairCode' new old pairs = + if ((new, old) `elem` pairs) + then [] + else if (nameBase new < nameBase old) + then [_TypeOrder [ConT old, ConT new] _FirstHigher] + else [_TypeOrder [ConT old, ConT new] _FirstLower ] + -- Useful type constructors. + _FirstLower = ConT ''TypeOrder_Lower + _FirstHigher = ConT ''TypeOrder_Higher + _TypeOrder = TySynInstD ''TypeOrder + +-- | This code generates all the instances of classes required by EVERY +-- reorderable type, irrespective of what other types there are. +generateCoreCode :: Name -> Q [Dec] +generateCoreCode new = getAllGenerators >>= concatMapM (compile new' . replaceName) . groupCode + where + -- The name of the thing being compiled. + name = nameBase new + new' = ConT new + + -- Replace "???" with the actual type name being currently compiled. + replaceName' [] = [] + replaceName' ('?' : '?' : '?' : rest) = name ++ replaceName' rest + replaceName' (r : rest) = r : replaceName' rest + replaceName (a, b) = (a, replaceName' (unlines b)) + + -- Find the code for all the available generators in the current code. + getAllGenerators = reify ''ReorderableInstance >>= (\ (ClassI _ instances) -> return $ map + (\ (InstanceD _ (AppT (AppT (AppT _ (ConT t)) (LitT (NumTyLit n))) (LitT (StrTyLit s))) _) -> + -- "t" is the parent type's name. + -- "n" is the allocated number. + -- "s" is the code. + (t, n, s) + ) instances + ) + + -- The base compiler + compile new (t, s) = isInstance t [new] >>= + -- Check if there is already an instance of this code for this type. + (\ b -> return $ if b + then [] -- Already done. + else case compileDecls s of -- Compile the code. + Left err -> error err -- Return the error. + -- Compiled OK, add on a new instance declaration too. + Right dec -> InstanceD [] (AppT (ConT t) new) [] : dec) + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- This is the compiler code. A lot of this is ripped from haskell-src-meta, +-- other bits are written by me. I did submit a pull request to get many of +-- these updates integrated in to the original library, but they haven't been +-- integrated, so I'm putting them here instead for compatibility. In short, +-- haskell-src-meta doesn't parse "type instance", but "haskell-src-exts", on +-- which it is based, does. As we need those, we intercept the translation, +-- look for any type family instances, and handle those here. Any other +-- declarations we pass on to be handled as normal. Unfortunately, this needs a +-- lot of code as we need to intercept ALL intermediate stages to get our new +-- code in to the right spot and pass the correct extensions. +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + + -- Note: Despite the confusingly indented comment block above, this code + -- is still within the "where" clause of "generateCoreCode". + compileDecls :: String -> Either String [Dec] + compileDecls = either Left (Right . toDecs2 . moduleDecls) + . parseResultToEither . parseModuleWithMode parseMode + + parseMode = ParseMode { + parseFilename = [] , + baseLanguage = Haskell2010, + extensions = map EnableExtension parseExts, + ignoreLinePragmas = False , + ignoreLanguagePragmas = False , + fixities = Nothing } + + parseExts = [ + EmptyDataDecls , + TypeFamilies , + PostfixOperators , + UnicodeSyntax , + FlexibleContexts , + PatternSignatures , + RankNTypes , + MultiParamTypeClasses ] + +----------------------------------------------------------------------------- + +class ToDecs2 a where toDecs2 :: a -> [Dec] + +-- * ToDecs InstDecl +instance ToDecs2 Hs.InstDecl where + toDecs2 (Hs.InsDecl decl) = toDecs2 decl + toDecs2 d = todo "toDec2" d + +-- * ToDecs HsDecl HsBinds + +instance ToDecs2 Hs.Decl where + toDecs2 a@(Hs.TypeSig _ ns t) = xs + where + xs = fmap (flip SigD (fixForall $ toType t) . toName) ns + + toDecs2 (Hs.InfixDecl _ assoc fixity ops) = + map (\op -> InfixD (Fixity fixity dir) (toName op)) ops + where + dir = case assoc of + Hs.AssocNone -> InfixN + Hs.AssocLeft -> InfixL + Hs.AssocRight -> InfixR + + toDecs2 a = [toDec2 a] + +instance ToDecs2 a => ToDecs2 [a] where + toDecs2 a = concatMap toDecs2 a + +instance ToDecs2 Hs.Binds where + toDecs2 (Hs.BDecls ds) = toDecs2 ds + +hsTypeToNameAndTypes2 :: Hs.Type -> (Name, [Type]) +hsTypeToNameAndTypes2 = getTypes [] . toType + where + getTypes ts (AppT a b) = getTypes (b : ts) a + getTypes ts (ForallT _ _ a) = getTypes ts a + getTypes ts (ConT con) = (con, ts) + getTypes ts (VarT con) = (con, ts) + getTypes ts (PromotedT con) = (con, ts) + getTypes _ a = nonsense "hsTypeToNameAndTypes2" "Unexpected type" a + +-- Had family declarations, but no instances. +toDec2 (Hs.TypeInsDecl _ t0 t1) = + TySynInstD n ts (toType t1) + where + (n, ts) = hsTypeToNameAndTypes2 t0 + +toDec2 (Hs.DataInsDecl _ Hs.DataType t qcds qns) = + DataInstD [] n ts (fmap qualConDeclToCon qcds) (fmap (toName . fst) qns) + where + (n, ts) = hsTypeToNameAndTypes2 t + +toDec2 (Hs.DataInsDecl _ Hs.NewType t (q:_) qns) = + NewtypeInstD [] n ts (qualConDeclToCon q) (fmap (toName . fst) qns) + where + (n, ts) = hsTypeToNameAndTypes2 t + +-- Default to the standard translation. +toDec2 a = toDec a + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- | Do `concatMap' with a function returning a monad. +concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] +concatMapM f a = mapM f a >>= return . concat + +-- | Concatenate two arrays in a monad. +cat :: (Monad m) => m [a] -> m [a] -> m [a] +cat a0 a1 = do + a0' <- a0 + a1' <- a1 + return $ a0' ++ a1' + +mapMaybes :: (a -> Maybe b) -> [a] -> ([b], [a]) +mapMaybes f [] = ([], []) +mapMaybes f (x : xs) = case f x of + Nothing -> (l, x : r) + Just x' -> (x' : l, r) + where + (l, r) = mapMaybes f xs + +-- Intra-Splice order is unimportant. +groupCode [] = [] +groupCode ((t, _, b) : xs) = (t, b : ms) : groupCode ns + where + sameGroup (t', _, b') + | t == t' = Just b' + | otherwise = Nothing + (ms, ns) = mapMaybes sameGroup xs +