packages feed

th-typegraph 0.27 → 0.28

raw patch · 3 files changed

+87/−56 lines, 3 files

Files

+ Language/Haskell/TH/TypeGraph/Lens.hs view
@@ -0,0 +1,77 @@+-- | The HasStack monad used in MIMO to construct lenses that look+-- deep into a record type.  However, it does not involve the Path+-- type mechanism, and is unaware of View instances and other things+-- that modify the type graph.  Lets see how it adapts.+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall #-}+module Language.Haskell.TH.TypeGraph.Lens+    ( makeTypeGraphLenses+    , lensNamePairs+    ) where++import Control.Category ((.))+import Control.Lens as Lens (makeLensesFor, view)+import Control.Monad.Readers (MonadReaders)+import qualified Control.Monad.Readers as Readers (view)+import Control.Monad.States (MonadStates)+import Control.Monad.Writer (execWriterT, tell)+import Data.Map as Map (keys)+import Language.Haskell.Exts.Syntax ()+import Language.Haskell.TH+import Language.Haskell.TH.Desugar (DsMonad)+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.Syntax hiding (lift)+import Language.Haskell.TH.TypeGraph.Edges (simpleEdges)+import Language.Haskell.TH.TypeGraph.Expand (E(E), ExpandMap)+import Language.Haskell.TH.TypeGraph.Stack (lensNamer, StackElement)+import Language.Haskell.TH.TypeGraph.TypeGraph (edges, TypeGraph)+import Language.Haskell.TH.TypeGraph.Vertex (etype)+import Prelude hiding ((.))++-- | Generate lenses to access the fields of the row types.  Like+-- Control.Lens.TH.makeLenses, but makes lenses for every field, and+-- instead of removing the prefix '_' to form the lens name it adds+-- the prefix "lens" and capitalizes the first letter of the field.+-- The only reason for this function is backwards compatibility,+-- makeLensesFor should be used instead.+makeTypeGraphLenses :: forall m. (DsMonad m, MonadStates ExpandMap m, MonadReaders [StackElement] m, MonadReaders TypeGraph m) =>+                       m [Dec]+makeTypeGraphLenses =+    execWriterT $ Readers.view edges >>= mapM doType . map (view etype) . Map.keys . simpleEdges+    where+      doType (E (ConT tname)) = qReify tname >>= doInfo+      doType _ = return ()+      doInfo (TyConI (NewtypeD _ tname _ _ _)) = lensNamePairs namer tname >>= \pairs -> runQ (makeLensesFor pairs tname) >>= tell+      doInfo (TyConI (DataD _ tname _ _ _)) = lensNamePairs namer tname >>= \pairs -> runQ (makeLensesFor pairs tname) >>= tell+      doInfo _ = return ()++namer :: Name -> Name -> Name -> (String, String)+namer _tname _cname fname = (nameBase fname, lensNamer (nameBase fname))++-- | Build the list of pairs used by makeLensesFor.+lensNamePairs :: Quasi m => (Name -> Name -> Name -> (String, String)) -> Name -> m [(String, String)]+lensNamePairs namefn tname =+    qReify tname >>= execWriterT . doInfo+    where+      doInfo (TyConI dec) = doDec dec+      doInfo _ = return ()+      doDec (NewtypeD _ _ _ con _) = doCon con+      doDec (DataD _ _ _ cons _) = mapM_ doCon cons+      doDec (TySynD _ _ _) = return ()+      doDec _ = return ()+      doCon (ForallC _ _ con) = doCon con+      doCon (RecC cname flds) = mapM_ (doField cname) flds+      doCon (NormalC _ _) = return ()+      doCon (InfixC _ _ _) = return ()+      doField cname (fname, _, (ConT fTypeName)) = qReify fTypeName >>= doFieldTypeName cname fname+      doField cname (fname, _, _) = tell [namefn tname cname fname]+      doFieldTypeName _cname _fname (PrimTyConI _ _ _) = return ()+      doFieldTypeName cname fname _ = tell [namefn tname cname fname]
Language/Haskell/TH/TypeGraph/Stack.hs view
@@ -24,34 +24,24 @@     , push       -- * Stack operations     , stackAccessor-    , makeLenses'     , traceIndented+    , lensNamer     ) where  import Control.Applicative import Control.Category ((.))-import Control.Lens (iso, Lens', lens, set, view)+import Control.Lens as Lens (iso, Lens', lens, set, view) import Control.Monad.Readers (MonadReaders(ask, local), ReaderT, runReaderT)-import Control.Monad.States (MonadStates)-import Control.Monad.Trans (lift)-import Control.Monad.Writer (WriterT, execWriterT, tell) import Data.Char (toUpper) import Data.Generics (Data, Typeable)-import Data.Map as Map (keys) import Data.Maybe (fromMaybe)-import Data.Set (Set) import Debug.Trace (trace) import Language.Haskell.Exts.Syntax () import Language.Haskell.TH-import Language.Haskell.TH.Desugar (DsMonad) import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding (lift)-import Language.Haskell.TH.TypeGraph.Edges (GraphEdges, simpleEdges, typeGraphEdges)-import Language.Haskell.TH.TypeGraph.Expand (E(E), ExpandMap) import Language.Haskell.TH.TypeGraph.Prelude (constructorName) import Language.Haskell.TH.TypeGraph.Shape (FieldType(..), fName, fType, constructorFieldTypes)-import Language.Haskell.TH.TypeGraph.TypeInfo (makeTypeInfo)-import Language.Haskell.TH.TypeGraph.Vertex (etype, TGV) import Prelude hiding ((.))  -- | The information required to extact a field value from a value.@@ -97,16 +87,17 @@ execStackT :: Monad m => StackT m a -> m a execStackT action = runReaderT action [] --- | Re-implementation of stack accessor in terms of stackLens-stackAccessor :: (Quasi m, MonadReaders [StackElement] m) => ExpQ -> Type -> m Exp-stackAccessor value typ0 =+-- | Return a lambda function that turns a value of Type typ0 into the+-- type implied by the stack elements.+stackAccessor :: (Quasi m, MonadReaders [StackElement] m) => m Exp+stackAccessor =     withStack f     where-      f [] = runQ value+      f [] = runQ [|id|]       f stk = do         lns <- runQ $ stackLens stk         Just typ <- stackType-        runQ [| view $(pure lns) $value :: $(pure typ) |]+        runQ [| \x -> (Lens.view $(pure lns) x) :: $(pure typ) |]  stackType :: MonadReaders [StackElement] m => m (Maybe Type) stackType =@@ -145,44 +136,6 @@                              -- \ x (Con a b c _ d e) -> Con a b c x d e                              $(lamE [conP cname (map varP as), varP f] (foldl appE (conE cname) (set (nthLens fieldPos) (varE f) (map varE as)))) |]        [| $(pure lns) {- :: Lens $(pure top) $(pure (fType fld)) -} |]---- | Generate lenses to access the fields of the row types.  Like--- Control.Lens.TH.makeLenses, but makes lenses for every field, and--- instead of removing the prefix '_' to form the lens name it adds--- the prefix "lens" and capitalizes the first letter of the field.--- The only reason for this function is backwards compatibility, the--- fields should be changed so they begin with _ and the regular--- makeLenses should be used.-makeLenses' :: forall m. (DsMonad m, MonadStates ExpandMap m) => (Type -> m (Set Type)) -> [Name] -> m [Dec]-makeLenses' extraTypes typeNames =-    execWriterT $ execStackT $ makeTypeInfo (lift . lift . extraTypes) st >>= runReaderT typeGraphEdges >>= \ (g :: GraphEdges TGV) -> (mapM doType . map (view etype) . Map.keys . simpleEdges $ g)-    where-      st = map ConT typeNames--      doType (E (ConT name)) = qReify name >>= doInfo-      doType _ = return ()-      doInfo (TyConI dec@(NewtypeD _ typeName _ con _)) = doCons dec typeName [con]-      doInfo (TyConI dec@(DataD _ typeName _ cons _)) = doCons dec typeName cons-      doInfo _ = return ()-      doCons dec typeName cons = mapM_ (\ con -> mapM_ (foldField (doField typeName) dec con) (constructorFieldTypes con)) cons--      -- (mkName $ nameBase $ tName dec) dec lensNamer) >>= tell-      doField :: Name -> FieldType -> StackT (WriterT [Dec] m) ()-      doField typeName (Named (fieldName, _, fieldType)) =-          doFieldType typeName fieldName fieldType-      doField _ _ = return ()-      doFieldType typeName fieldName (ForallT _ _ typ) = doFieldType typeName fieldName typ-      doFieldType typeName fieldName fieldType@(ConT fieldTypeName) = qReify fieldTypeName >>= doFieldInfo typeName fieldName fieldType-      doFieldType typeName fieldName fieldType = makeLens typeName fieldName fieldType-      doFieldInfo typeName fieldName fieldType (TyConI _fieldTypeDec) = makeLens typeName fieldName fieldType-      doFieldInfo _ _ _ (PrimTyConI _ _ _) = return ()-      doFieldInfo _ _ _ info = error $ "makeLenses - doFieldType: " ++ show info--      makeLens typeName fieldName fieldType =-          do let lensName = mkName (lensNamer (nameBase fieldName))-             sig <- runQ $ sigD lensName (runQ [t|Lens' $(conT typeName) $(pure fieldType)|])-             val <- runQ $ valD (varP lensName) (normalB (runQ [|lens $(varE fieldName) (\ s x -> $(recUpdE [|s|] [ (,) <$> pure fieldName <*> [|x|] ]))|])) []-             return [sig, val] >>= tell  -- | Given a field name, return the name to use for the corresponding lens. lensNamer :: String -> String
th-typegraph.cabal view
@@ -1,5 +1,5 @@ name:               th-typegraph-version:            0.27+version:            0.28 cabal-version:      >= 1.10 build-type:         Simple license:            BSD3@@ -38,6 +38,7 @@     Language.Haskell.TH.TypeGraph.Edges     Language.Haskell.TH.TypeGraph.Expand     Language.Haskell.TH.TypeGraph.Free+    Language.Haskell.TH.TypeGraph.Lens     Language.Haskell.TH.TypeGraph.Prelude     Language.Haskell.TH.TypeGraph.Shape     Language.Haskell.TH.TypeGraph.Stack