diff --git a/Data/Generics/Alloy.hs b/Data/Generics/Alloy.hs --- a/Data/Generics/Alloy.hs +++ b/Data/Generics/Alloy.hs @@ -36,6 +36,7 @@ -- () provides examples of each -- of these. The tutorial also explains how to use the "Data.Generics.Alloy.GenInstances" -- module to generate the instances that Alloy needs for your data. + module Data.Generics.Alloy ( module Data.Generics.Alloy.Pure, module Data.Generics.Alloy.Effect, @@ -47,5 +48,4 @@ import Data.Generics.Alloy.Effect import Data.Generics.Alloy.Route import Data.Generics.Alloy.Schemes - diff --git a/Data/Generics/Alloy/Effect.hs b/Data/Generics/Alloy/Effect.hs --- a/Data/Generics/Alloy/Effect.hs +++ b/Data/Generics/Alloy/Effect.hs @@ -87,7 +87,7 @@ -- in this module. Whereas there is, for example, both 'makeRecurseA' and 'makeRecurseM', -- there is only one terminator for the opsets, 'BaseOpA', which should be used -- regardless of whether you use 'makeRecurseA' or 'makeRecurseM'. -data BaseOpA m = BaseOpA +data BaseOpA (m :: * -> *) = BaseOpA -- | The function to give you an item of type 'BaseOpA'. baseOpA :: BaseOpA m diff --git a/Data/Generics/Alloy/GenInstances.hs b/Data/Generics/Alloy/GenInstances.hs --- a/Data/Generics/Alloy/GenInstances.hs +++ b/Data/Generics/Alloy/GenInstances.hs @@ -1,5 +1,5 @@ -- Alloy. --- Copyright (c) 2008-2009, University of Kent. +-- Copyright (c) 2008-2009, 2012 University of Kent. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -75,7 +75,12 @@ import Data.Ord import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Typeable as Ty +#if __GLASGOW_HASKELL__ < 702 +type TypeRepKey = Int +#endif + -- | The option controlling whether the generated instances can be overlapped. -- If you choose 'GenWithOverlapped' many less instances (around half, in our -- experience) will be generated, but you must enable the @@ -199,7 +204,7 @@ -- in a Map. findTypesIn (const Nothing) (k, v) -- This does types in k and v, and their pairing tk <- liftIO $ typeKey m - modify (Map.insert tk (show $ typeOf m, + modify (Map.insert tk (toQualName m, Detailed (DataBox m) [DataBox (k, v), DataBox k, DataBox v] (\cl (funcSameType, funcNewType) -> concat [ case cl of @@ -229,7 +234,7 @@ -- Must find types for contained types, in case they are not generated elsewhere. findTypesIn (const Nothing) x tk <- liftIO $ typeKey s - modify (Map.insert tk (show $ typeOf s, + modify (Map.insert tk (toQualName s, Detailed (DataBox s) [DataBox x] (\cl (funcSameType, funcNewType) -> concat [ case cl of @@ -382,21 +387,15 @@ Plain {} -> Nothing Detailed _ contains _ -> Just contains - wName = show $ typeOf w + (wName, wMod) = toQualNameMod w wMunged = mungeName wName wDType = dataTypeOf w wCtrs = if isAlgType wDType then dataTypeConstrs wDType else [] - -- The module prefix of this type, so we can use it in constructor names. - modPrefix - = if '.' `elem` (takeWhile (\c -> isAlphaNum c || c == '.') wName) - then takeWhile (/= '.') wName ++ "." - else "" - ctrArgs ctr = gmapQ DataBox (fromConstr ctr :: t) ctrArgTypes types - = [show $ typeOf w | DataBox w <- types] + = [toQualName w | DataBox w <- types] -- Given the context (a list of instance requirements), the left-hand ops, -- the right-hand ops, and a list of lines for the body of the class, generates @@ -540,14 +539,14 @@ where argNums = [0 .. ((length $ ctrArgs ctr) - 1)] ctrS = show ctr - ctrName = modPrefix ++ ctrS + ctrName = wMod ++ ctrS makeCtr vs = ctrName ++ concatMap (" " ++) vs ctrInput = makeCtr ["a" ++ show i | i <- argNums] ctrMod = makeCtr ["b" ++ show i | i <- argNums] -- | An instance that describes how to apply -- or not apply -- a -- transformation. - otherInst :: Data s => Int -> Set.Set Int -> s -> Int -> [String] + otherInst :: Data s => TypeRepKey -> Set.Set TypeRepKey -> s -> TypeRepKey -> [String] otherInst wKey containedKeys c cKey = if not shouldGen then [] else genInst context @@ -555,7 +554,7 @@ "ops" impl where - cName = show $ typeOf c + cName = toQualName c (shouldGen, context, impl) -- This type matches the transformation: apply it. | wKey == cKey @@ -582,7 +581,7 @@ -- | The lines in the header that form the import statements necessary for the -- Alloy instances. instanceImports :: [String] -instanceImports = map ("import " ++) ["Control.Applicative", "Control.Monad", "Data.Generics.Alloy"] +instanceImports = map ("import " ++) ["Control.Applicative", "Control.Monad", "Data.Generics.Alloy", "qualified GHC.Types"] -- | Like 'instanceImports' but also adds the lines needed for maps and sets. -- If you use 'genMapInstance' or 'genSetInstance', use this function, otherwise @@ -656,12 +655,42 @@ instance Eq DataBox where (==) (DataBox x) (DataBox y) = typeOf x == typeOf y - -type TypeMap = Map Int (String, Witness) +type TypeMap = Map TypeRepKey (String, Witness) type TypeMapM = StateT TypeMap IO -typeKey :: Typeable t => t -> IO Int +typeKey :: Typeable t => t -> IO TypeRepKey typeKey x = typeRepKey $ typeOf x + +toQualName :: Typeable t => t -> String +toQualName w = fst (toQualNameMod w) + +-- First item is name of type, with everything inside qualified +-- Second item is the module prefix (if any) of the outermost type +toQualNameMod :: Typeable t => t -> (String, String) +toQualNameMod w = toQualNameMod' (typeOf w) + +toQualNameMod' :: TypeRep -> (String, String) +toQualNameMod' tr = case (show con, args) of + ("[]", [arg]) -> -- Lists are special case, don't qualify and use [ ] to wrap: + ("[" ++ fst (toQualNameMod' arg) ++ "]", "") + ("()", []) -> ("()", "") -- Unit is special, don't qualify + ('(':',':_, args) -> -- Tuples are also special, don't qualify: + ("(" ++ show con ++ concat (Prelude.map ((' ' :) . fst . toQualNameMod') args) ++ ")" + , "") + -- Special case Integer, whose definition is hidden: + _ | qualCon con == "GHC.Integer.Type.Integer" -> ("Prelude.Integer", "") + _ -> ("(" ++ qualCon con ++ concat (Prelude.map ((' ' :) . fst . toQualNameMod') args) ++ ")" + , modPrefix con) + where + (con, args) = splitTyConApp tr + +qualCon :: TyCon -> String +qualCon wc = modPrefix wc ++ show wc + +modPrefix :: TyCon -> String +modPrefix wc = case Ty.tyConModule wc of + "" -> "" + m -> m ++ "." findTypesIn' :: Data t => (DataBox -> Maybe [DataBox]) -> t -> IO TypeMap findTypesIn' f x = execStateT (findTypesIn f x) Map.empty diff --git a/Data/Generics/Alloy/Route.hs b/Data/Generics/Alloy/Route.hs --- a/Data/Generics/Alloy/Route.hs +++ b/Data/Generics/Alloy/Route.hs @@ -189,7 +189,7 @@ infixr 7 :-@ -- | The terminator for opsets with 'AlloyARoute'. -data BaseOpARoute m outer = BaseOpARoute +data BaseOpARoute (m :: * -> *) outer = BaseOpARoute -- | A handy synonym for a monadic/applicative opset with only one item, to use with 'AlloyARoute'. diff --git a/alloy.cabal b/alloy.cabal --- a/alloy.cabal +++ b/alloy.cabal @@ -1,9 +1,9 @@ Name: alloy -Version: 1.0.0 +Version: 1.1.0 License: BSD3 License-File: LICENSE Author: Neil Brown and Adam Sampson -Copyright: Copyright 2008-2009, University of Kent +Copyright: Copyright 2008-2009, 2012 University of Kent Maintainer: neil@twistedsquare.com Cabal-Version: >= 1.2.3 Build-type: Simple @@ -30,10 +30,7 @@ tutorial/Selective.lhs Library - if (impl(ghc < 6.10)) - Build-Depends: base >= 3 && < 4, containers, mtl - else - Build-Depends: base >= 4 && < 5, containers, mtl, syb + Build-Depends: base >= 4.3 && < 5, containers, mtl, syb Exposed-modules: Data.Generics.Alloy Data.Generics.Alloy.Effect @@ -42,7 +39,8 @@ Data.Generics.Alloy.Route Data.Generics.Alloy.Schemes - Extensions: ExistentialQuantification + Extensions: CPP + ExistentialQuantification FlexibleContexts FlexibleInstances KindSignatures diff --git a/tutorial/CompanyDatatypes.lhs b/tutorial/CompanyDatatypes.lhs --- a/tutorial/CompanyDatatypes.lhs +++ b/tutorial/CompanyDatatypes.lhs @@ -7,7 +7,7 @@ {-# LANGUAGE DeriveDataTypeable #-} module CompanyDatatypes where -import Data.Generics hiding (Unit) +import Data.Generics -- The organisational structure of a company