packages feed

newtype-deriving (empty) → 0.1.0

raw patch · 8 files changed

+393/−0 lines, 8 filesdep +basedep +base-preludedep +eithersetup-changed

Dependencies added: base, base-prelude, either, monad-control, newtype-deriving, template-haskell, transformers, transformers-base

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2014, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ demo/Main.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE UndecidableInstances, TypeFamilies, FlexibleInstances,+             TemplateHaskell, GeneralizedNewtypeDeriving,+             MultiParamTypeClasses #-}+module Main where++import Prelude ()+import BasePrelude+import NewtypeDeriving+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Monad.Trans.Class+import Control.Monad.Trans.Either+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer+++main =+  return ()+++newtype T m a =+  T (ReaderT Int (StateT Char (WriterT [Int] (EitherT String (MaybeT m)))) a)+  deriving (Functor, Applicative, Monad)++monadTransInstance ''T+monadTransControlInstance ''T+monadBaseTransformerInstance ''T+monadBaseControlTransformerInstance ''T+
+ library/NewtypeDeriving.hs view
@@ -0,0 +1,94 @@+-- |+-- This module provides+-- Template Haskell based derivers for typical newtype instances, +-- which the @GeneralizedNewtypeDeriving@ extension refuses to handle. +-- +-- Here is what it allows you to do:+-- +-- >{-# LANGUAGE UndecidableInstances, TypeFamilies, FlexibleInstances,+-- >             TemplateHaskell, GeneralizedNewtypeDeriving,+-- >             MultiParamTypeClasses #-}+-- >+-- >import NewtypeDeriving+-- >import Control.Monad.Base+-- >import Control.Monad.Trans.Control+-- >import Control.Monad.Trans.Class+-- >import Control.Monad.Trans.Either+-- >import Control.Monad.Trans.Maybe+-- >import Control.Monad.Trans.State+-- >import Control.Monad.Trans.Reader+-- >import Control.Monad.Trans.Writer+-- >+-- >newtype T m a =+-- >  T (ReaderT Int (StateT Char (WriterT [Int] (EitherT String (MaybeT m)))) a)+-- >  deriving (Functor, Applicative, Monad)+-- >+-- >monadTransInstance ''T+-- >monadTransControlInstance ''T+-- >monadBaseTransformerInstance ''T+-- >monadBaseControlTransformerInstance ''T+module NewtypeDeriving where++import BasePrelude+import Language.Haskell.TH+import qualified NewtypeDeriving.Reification as Reification+import qualified NewtypeDeriving.Rendering as Rendering+++-- |+-- Given a name of a newtype wrapper +-- produce an instance of+-- @Control.Monad.Trans.Class.'Control.Monad.Trans.Class.MonadTrans'@.+monadTransInstance :: Name -> Q [Dec]+monadTransInstance n =+  do+    Reification.Newtype typeName conName innerType <-+      join $ fmap (either fail return) $+      Reification.reifyNewtype n+    let+      layers =+        unfoldr Reification.peelTransformer $ +        case innerType of AppT m _ -> m+    return $ pure $+      Rendering.monadTransInstance (ConT typeName) conName (length layers)++-- |+-- Given a name of a newtype wrapper +-- produce an instance of+-- @Control.Monad.Base.'Control.Monad.Base.MonadBase'@,+-- which is specialised for monad transformers.+monadBaseTransformerInstance :: Name -> Q [Dec]+monadBaseTransformerInstance n =+  do+    Reification.Newtype typeName conName innerType <-+      join $ fmap (either fail return) $+      Reification.reifyNewtype n+    return $ pure $+      Rendering.monadBaseTransformerInstance (ConT typeName) conName++-- |+-- Given a name of a newtype wrapper +-- produce an instance of+-- @Control.Monad.Trans.Control.'Control.Monad.Trans.Control.MonadTransControl'@.+monadTransControlInstance :: Name -> Q [Dec]+monadTransControlInstance n =+  do+    Reification.Newtype typeName conName innerType <-+      join $ fmap (either fail return) $+      Reification.reifyNewtype n+    let+      layers =+        unfoldr Reification.peelTransformer $ +        case innerType of AppT m _ -> m+    return $ pure $ +      Rendering.monadTransControlInstance (ConT typeName) conName layers++-- |+-- Given a name of a newtype wrapper +-- produce an instance of+-- @Control.Monad.Trans.Control.'Control.Monad.Trans.Control.MonadBaseControl'@,+-- which is specialised for monad transformers.+monadBaseControlTransformerInstance :: Name -> Q [Dec]+monadBaseControlTransformerInstance n =+  return $ pure $+    Rendering.monadBaseControlTransformerInstance (ConT n)
+ library/NewtypeDeriving/Reification.hs view
@@ -0,0 +1,41 @@+module NewtypeDeriving.Reification where++import BasePrelude+import Language.Haskell.TH++++data Newtype =+  Newtype {+    newtypeTypeName :: Name,+    newtypeConstructorName :: Name,+    newtypeInnerType :: Type+  }+  deriving (Show)++reifyNewtype :: Name -> Q (Either String Newtype)+reifyNewtype =+  fmap parseInfo . reify+  where+    parseInfo =+      \case+        TyConI (NewtypeD _ typeName _ con derivations) -> do+          (conName, innerType) <-+            case con of+              NormalC n [(_, t)] -> Right (n, t)+              RecC n [(_, _, t)] -> Right (n, t)+              _ -> Left $ "Invalid constructor: " <> show con+          return $ Newtype typeName conName innerType+        i ->+          Left $ "Invalid type of a name"++-- |+-- Given a kind @* -> *@ type, +-- peel off a kind @(* -> *) -> (* -> *)@ type (the monad-transformer)+-- and another @* -> *@ type (the inner monad).+peelTransformer :: Type -> Maybe (Type, Type)+peelTransformer =+  \case+    AppT t m -> Just (t, m)+    _ -> Nothing+
+ library/NewtypeDeriving/Rendering.hs view
@@ -0,0 +1,96 @@+module NewtypeDeriving.Rendering where++import BasePrelude+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Monad.Trans.Class+import NewtypeDeriving.TH+import Language.Haskell.TH+++monadTransInstance +  :: Type   -- ^ Type of Newtype+  -> Name   -- ^ Constructor name+  -> Int    -- ^ Amount of inner layers+  -> Dec+monadTransInstance transformerType conName layersCount =+  head $ purifyQ $+  [d|+    instance MonadTrans $(pure transformerType) where+      lift =+        $(pure liftExp)+  |]+  where+    liftExp =+      foldl' composeExp (ConE conName) $ replicate layersCount (VarE 'lift)++monadBaseTransformerInstance+  :: Type+  -> Name+  -> Dec+monadBaseTransformerInstance transformerType conName =+  head $ purifyQ $+  [d|+    instance MonadBase b m => MonadBase b ($(pure transformerType) m) where+      liftBase =+        $(conE conName) . liftBase+  |]++monadTransControlInstance +  :: Type   -- ^ Type of Newtype+  -> Name   -- ^ Constructor name+  -> [Type] -- ^ Layers of inner transfomer types+  -> Dec+monadTransControlInstance transformerType conName layers =+  head $ purifyQ $+  [d|+    instance MonadTransControl $(pure transformerType) where+      type StT $(pure transformerType) $(varT stArgName) = +        $(pure stType)+      liftWith =+        $(pure liftWithExp)+      restoreT =+        $(pure restoreTExp)+  |]+  where+    restoreTExp =+      foldl' composeExp (ConE conName) $ +      replicate (length layers) (VarE 'restoreT)+    liftWithExp =+      LamE [VarP onUnliftVarName] $+      AppE (ConE conName) $+      foldr' (\n -> AppE (VarE 'liftWith) . LamE [VarP n])+             (AppE (VarE onUnliftVarName) unliftExp)+             (unliftNames)+      where+        onUnliftVarName =+          mkName "onUnlift"+        unliftNames =+          zipWith (\_ i -> mkName $ "unlift" <> show i) layers [1..]+        unliftExp =+          foldr' composeExp unwrapExp $ map VarE $ reverse unliftNames+        unwrapExp =+          LamE [ConP conName [VarP mVarName]] (VarE mVarName)+          where+            mVarName = +              mkName "m"+    stArgName =+      mkName "a"+    stType =+      foldl' (flip AppT) (VarT stArgName) $ map (AppT (ConT ''StT)) layers++monadBaseControlTransformerInstance+  :: Type+  -> Dec+monadBaseControlTransformerInstance t =+  head $ purifyQ $+  [d|+    instance MonadBaseControl b m => MonadBaseControl b ($(pure t) m) where+      type StM ($(pure t) m) a = ComposeSt $(pure t) m a+      liftBaseWith = defaultLiftBaseWith+      restoreM = defaultRestoreM+  |]++composeExp :: Exp -> Exp -> Exp+composeExp a b =+  UInfixE a (VarE '(.)) b
+ library/NewtypeDeriving/TH.hs view
@@ -0,0 +1,11 @@+module NewtypeDeriving.TH where++import BasePrelude+import Language.Haskell.TH+++purifyQ :: Q a -> a+purifyQ = unsafePerformIO . runQ++tryToReify :: Name -> Q (Maybe Info)+tryToReify n = recover (return Nothing) (fmap Just $ reify n)
+ newtype-deriving.cabal view
@@ -0,0 +1,96 @@+name:+  newtype-deriving+version:+  0.1.0+synopsis:+  Instance derivers for newtype wrappers+description:+  Template Haskell based derivers for typical newtype instances, +  which the @GeneralizedNewtypeDeriving@ extension refuses to handle.+  .+  Amongst others provides support for the \"monad-control\" classes:+  .+  * @Control.Monad.Trans.Control.'Control.Monad.Trans.Control.MonadTransControl'@+  .+  * @Control.Monad.Trans.Control.'Control.Monad.Trans.Control.MonadBaseControl'@+category:+  Control, Template Haskell+homepage:+  https://github.com/nikita-volkov/newtype-deriving +bug-reports:+  https://github.com/nikita-volkov/newtype-deriving/issues +author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2014, Nikita Volkov+license:+  MIT+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  >=1.10+++source-repository head+  type:+    git+  location:+    git://github.com/nikita-volkov/newtype-deriving.git+++library+  hs-source-dirs:+    library+  ghc-options:+    -funbox-strict-fields+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  other-modules:+    NewtypeDeriving.Reification+    NewtypeDeriving.Rendering+    NewtypeDeriving.TH+  exposed-modules:+    NewtypeDeriving+  build-depends:+    template-haskell >= 2.7 && < 2.10,+    monad-control >= 1.0 && < 1.1,+    transformers-base == 0.4.*,+    transformers >= 0.3 && < 0.5,+    base-prelude >= 0.1.3 && < 0.2,+    base >= 4.5 && < 4.8+++-- Well, it's not a benchmark actually, +-- but in Cabal there's no better way to specify an executable, +-- which is not intended for distribution.+benchmark demo+  type: +    exitcode-stdio-1.0+  hs-source-dirs:+    demo+  main-is:+    Main.hs+  ghc-options:+    -O2+    -threaded+    "-with-rtsopts=-N"+    -funbox-strict-fields+    -ddump-splices+  default-language:+    Haskell2010+  build-depends:+    newtype-deriving,+    either >= 4.3 && < 4.4,+    monad-control >= 1.0 && < 1.1,+    transformers-base == 0.4.*,+    transformers >= 0.3 && < 0.5,+    base-prelude >= 0.1.3 && < 0.2,+    base >= 4.5 && < 4.8++