{- Copyright 2010-2012 Cognimeta Inc. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -} module Cgm.Data.Structured.Derive ( deriveStructured ) where import Language.Haskell.TH import Control.Monad -- TODO: Deriving an instance is problematic since it must be exported. And most often this is -- undesirable because it breaks the type abstraction. Instead we should derive -- a method which provides the bijection, and modules which perform the derivation -- would then be free to define an instance and/or use the bijection. We may want to -- derive a structure type also. --instance Structured a => Structured [a] where -- type Structure [a] = Either () (a, [a]) -- structure [] = Left () -- structure (x : xs) = Right (x, xs) -- fromStructure (Left ()) = [] -- fromStructure (Right (x, xs)) = (x : xs) --[InstanceD [ClassP Structured.Structured [VarT a_0]] -- (AppT (ConT Structured.Structured) -- (AppT ListT (VarT a_0))) -- [TySynInstD Structure -- [AppT ListT (VarT a_1)] -- (AppT (AppT (ConT Data.Either.Either) (ConT GHC.Unit.())) -- (AppT (AppT (TupleT 2) (VarT a_1)) -- (AppT ListT (VarT a_1)))), -- FunD structure [Clause [ConP GHC.Types.[] []] -- (NormalB (AppE (ConE Data.Either.Left) (ConE GHC.Unit.()))) [], -- Clause [InfixP (VarP x_2) GHC.Types.: (VarP xs_3)] -- (NormalB (AppE (ConE Data.Either.Right) (TupE [VarE x_2,VarE xs_3]))) []], -- FunD fromStructure [Clause [ConP Data.Either.Left [ConP GHC.Unit.() []]] -- (NormalB (ConE GHC.Types.[])) [], -- Clause [ConP Data.Either.Right [TupP [VarP x_4,VarP xs_5]]] -- (NormalB (InfixE (Just (VarE x_4)) (ConE GHC.Types.:) (Just (VarE xs_5)))) []]]] -- Options for defintion of generic persistence -- http://www.cse.unsw.edu.au/~chak/papers/instant-generics.pdf is interresting but its -- implementation instant-generics, does not yet come with a Template Haskell -- function to derive Representable instances -- See also "A generic deriving mechanism for Haskell, Draft" -- (http://www.dreixel.net/research/pdf/gdmh_draft.pdf) -- To be presented at Haskell Symposium 2010, in September -- Implementation is in UHC, not GHC for now. -- GDMH seems very powerful, but it appears we do not need tagging and meta-information. -- It also avoids using type families and functional dependencies, to show that their -- design is workable without those new features. But here we can use type famillies -- as in instant-generics. We could use the instant-generics design (and library). -- We might not need to use the shallow representation, but if we stay close to -- their design we will have less thinking to do, and we may be able to use -- their library directly (and add TH to derive instances). The shallow representation appears -- necessary to support subuniverses for specific generic methods (something we think -- we do no need at this point). -- DEBUG with -ddump-splices deriveStructured :: Name -> Q [Dec] deriveStructured typName = do (TyConI d) <- reify typName (type_name,tvars,_,constructors) <- typeInfo (return d) appliedType <- appsT $ conT' type_name : map (varT . fromTyVar) tvars let structureType = tySynInstD (mkName "Structure") [return appliedType] $ nestedEitherT $ map (nestedTupT . map (return . snd) . snd) constructors structureFun = do clauses <- mapM structureClause constructors return $ FunD (mkName "structure") $ addETags clauses structureClause (conName, components) = do vars <- newNames "a" components clause [conP conName $ map varP vars] (normalB $ nestedTupE $ map varE vars) [] fromStructureFun = do clauses <- mapM fromStructureClause constructors return $ FunD (mkName "fromStructure") $ addPTags clauses fromStructureClause (conName, components) = do vars <- newNames "s" components clause [nestedTupP $ map varP vars] (normalB (appsE (conE conName : map varE vars))) [] in sequence [instanceD (cxt []) (appT (conT $ mkName "Structured") (return appliedType)) [structureType, structureFun, fromStructureFun]] conT' name = if nameBase name == "[]" then listT else conT name -- A foldr with special cases for empty lists and singletons nested :: b -> (a -> b) -> (a -> b -> b) -> [a] -> b nested empty single pair [] = empty nested empty single pair (x:[]) = single x nested empty single pair (x:xs) = pair x $ nested empty single pair xs nestedTupE = nested (tupE []) id (\a b -> tupE [a, b]) nestedTupT = nested (tupT []) id (\a b -> tupT [a, b]) nestedTupP = nested (tupP []) id (\a b -> tupP [a, b]) nestedEitherT = nested (error "nestedEitherT []") id eitherT addETags = nested [] return $ \c cs -> mapClauseBodyE leftETag c : map (mapClauseBodyE rightETag) cs addPTags = nested [] return $ \c cs -> mapClausePat1 leftPTag c : map (mapClausePat1 rightPTag) cs leftETag = AppE $ ConE $ mkName "Left" rightETag = AppE $ ConE $ mkName "Right" leftPTag p = ConP (mkName "Left") [p] rightPTag p = ConP (mkName "Right") [p] mapClauseBodyE f (Clause ps b ds) = Clause ps (mapBodyE f b) ds mapClausePat1 f (Clause [p] b ds) = Clause [f p] b ds mapBodyE f (GuardedB gs) = GuardedB $ map (\p -> (fst p, f $ snd p)) gs mapBodyE f (NormalB e) = NormalB $ f e appsT :: [TypeQ] -> TypeQ appsT [] = error "appsT []" appsT [x] = x appsT (x:y:zs) = appsT $ appT x y : zs tupT ts = appsT $ tupleT (length ts) : ts eitherT ta tb = appsT [conT (mkName "Either"), ta, tb] fromTyVar :: TyVarBndr -> Name fromTyVar (PlainTV v) = v fromTyVar (KindedTV v _) = v newNames prefix = mapM $ const $ newName prefix -- And some borrowed helper code taken from Syb III / replib 0.2 typeInfo :: DecQ -> Q (Name, [TyVarBndr], [(Name, Int)], [(Name, [(Maybe Name, Type)])]) typeInfo m = do d <- m case d of d@DataD{} -> return (simpleName $ name d, paramsA d, consA d, termsA d) d@NewtypeD{} -> return (simpleName $ name d, paramsA d, consA d, termsA d) _ -> error ("derive: not a data type declaration: " ++ show d) where consA (DataD _ _ _ cs _) = map conA cs consA (NewtypeD _ _ _ c _) = [ conA c ] paramsA (DataD _ _ ps _ _) = ps paramsA (NewtypeD _ _ ps _ _) = ps termsA (DataD _ _ _ cs _) = map termA cs termsA (NewtypeD _ _ _ c _) = [ termA c ] termA (NormalC c xs) = (c, map (\x -> (Nothing, snd x)) xs) termA (RecC c xs) = (c, map (\(n, _, t) -> (Just $ simpleName n, t)) xs) termA (InfixC t1 c t2) = (c, [(Nothing, snd t1), (Nothing, snd t2)]) conA (NormalC c xs) = (simpleName c, length xs) conA (RecC c xs) = (simpleName c, length xs) conA (InfixC _ c _) = (simpleName c, 2) name (DataD _ n _ _ _) = n name (NewtypeD _ n _ _ _) = n name d = error $ show d simpleName :: Name -> Name simpleName nm = let s = nameBase nm in case dropWhile (/=':') s of [] -> mkName s _:[] -> mkName s _:t -> mkName t