summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authortek <>2019-03-13 18:47:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-03-13 18:47:00 (GMT)
commit84aeb201776ac6abb739965e91e1b9ac931733ce (patch)
tree3e86822a2f90e75a3ed53f36c4ae0a5d6e2a12e5
version 0.2.0.00.2.0.0
-rw-r--r--LICENSE55
-rw-r--r--README.md65
-rw-r--r--cornea.cabal81
-rw-r--r--lib/Control/Monad/DeepError.hs28
-rw-r--r--lib/Control/Monad/DeepState.hs25
-rw-r--r--lib/Data/DeepLenses.hs121
-rw-r--r--lib/Data/DeepPrisms.hs132
-rw-r--r--test/u/DeepErrorSpec.hs62
-rw-r--r--test/u/DeepStateSpec.hs56
-rw-r--r--test/u/SpecMain.hs11
10 files changed, 636 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..c5402b9
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,55 @@
+# Blue Oak Model License
+
+Version 1.0.0
+
+## Purpose
+
+This license gives everyone as much permission to work with
+this software as possible, while protecting contributors
+from liability.
+
+## Acceptance
+
+In order to receive this license, you must agree to its
+rules. The rules of this license are both obligations
+under that agreement and conditions to your license.
+You must not do anything with this software that triggers
+a rule that you cannot or will not follow.
+
+## Copyright
+
+Each contributor licenses you to do everything with this
+software that would otherwise infringe that contributor's
+copyright in it.
+
+## Notices
+
+You must ensure that everyone who gets a copy of
+any part of this software from you, with or without
+changes, also gets the text of this license or a link to
+<https://blueoakcouncil.org/license/1.0.0>.
+
+## Excuse
+
+If anyone notifies you in writing that you have not
+complied with [Notices](#notices), you can keep your
+license by taking all practical steps to comply within 30
+days after the notice. If you do not do so, your license
+ends immediately.
+
+## Patent
+
+Each contributor licenses you to do everything with this
+software that would otherwise infringe any patent claims
+they can license or become able to license.
+
+## Reliability
+
+No contributor can revoke this license.
+
+## No Liability
+
+***As far as the law allows, this software comes as is,
+without any warranty or condition, and no contributor
+will be liable to anyone for any damages related to this
+software or this license, under any kind of legal claim.***
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..d3f147b
--- /dev/null
+++ b/README.md
@@ -0,0 +1,65 @@
+# Intro
+
+Classes for accessing and mutating nested data types with corresponding adapter classes for `MonadState` and `MonadError`.
+
+# Example
+
+For `MonadError`:
+
+```haskell
+{-# LANGUAGE TemplateHaskell #-}
+
+import Control.Monad.DeepError (MonadDeepError(throwHoist))
+import Control.Monad.Trans.Except (runExceptT)
+import Data.DeepPrisms (deepPrisms)
+
+newtype Error = Error String
+
+newtype Inner = Inner Error
+deepPrisms ''Inner
+
+data Mid = Mid Inner
+deepPrisms ''Mid
+
+newtype Outer = Outer Mid
+deepPrisms ''Outer
+
+throwDeep :: MonadDeepError e Inner m => m ()
+throwDeep = throwHoist (Inner (Error "boom"))
+
+main :: IO (Either Outer ())
+main = runExceptT throwDeep
+```
+
+In `main`, `MonadError Outer IO` and `DeepPrisms Outer Inner` is summoned.
+
+Analogously for `MonadState`:
+
+```haskell
+{-# LANGUAGE TemplateHaskell #-}
+
+import Control.Monad.DeepState (MonadDeepState(get, gets, put))
+import Control.Monad.Trans.State (execStateT)
+import Data.DeepLenses (deepLenses)
+
+newtype S = S Int
+
+newtype Inner = Inner { innerS :: S }
+deepLenses ''Inner
+
+data Mid = Mid { _midInner :: Inner }
+deepLenses ''Mid
+
+newtype Outer = Outer { _outerMid :: Mid }
+deepLenses ''Outer
+
+stateDeep :: MonadDeepState s Inner m => m ()
+stateDeep = do
+ (Inner (S a)) <- get
+ b <- gets $ \(Inner (S b)) -> b
+ put (Inner (S (a + b + 3)))
+
+main :: IO Outer
+main = do
+ execStateT stateDeep (Outer (Mid (Inner (S 5))))
+```
diff --git a/cornea.cabal b/cornea.cabal
new file mode 100644
index 0000000..963bc95
--- /dev/null
+++ b/cornea.cabal
@@ -0,0 +1,81 @@
+cabal-version: 1.12
+name: cornea
+version: 0.2.0.0
+license: OtherLicense
+license-file: LICENSE
+copyright: 2019 Torsten Schmits
+maintainer: tek@tryp.io
+author: Torsten Schmits
+homepage: https://github.com/tek/cornea#readme
+bug-reports: https://github.com/tek/cornea/issues
+synopsis: classy optical monadic state
+description:
+ Please see the README on GitHub at <https://github.com/tek/cornea>
+category: Lens
+build-type: Simple
+extra-source-files:
+ README.md
+
+source-repository head
+ type: git
+ location: https://github.com/tek/cornea
+
+library
+ exposed-modules:
+ Control.Monad.DeepError
+ Control.Monad.DeepState
+ Data.DeepLenses
+ Data.DeepPrisms
+ hs-source-dirs: lib
+ other-modules:
+ Paths_cornea
+ default-language: Haskell2010
+ default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals
+ ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable
+ DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable
+ DoAndIfThenElse EmptyDataDecls ExistentialQuantification
+ FlexibleContexts FlexibleInstances FunctionalDependencies GADTs
+ GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase
+ MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns
+ OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds
+ RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving
+ TupleSections TypeApplications TypeFamilies TypeSynonymInstances
+ UnicodeSyntax ViewPatterns
+ build-depends:
+ base >=4.7 && <5,
+ lens >=4.16.1 && <4.17,
+ mtl >=2.2.2 && <2.3,
+ template-haskell >=2.13.0.0 && <2.14,
+ th-abstraction >=0.2.10.0 && <0.3,
+ transformers >=0.5.5.0 && <0.6
+
+test-suite cornea-unit
+ type: exitcode-stdio-1.0
+ main-is: SpecMain.hs
+ hs-source-dirs: test/u
+ other-modules:
+ DeepErrorSpec
+ DeepStateSpec
+ Paths_cornea
+ default-language: Haskell2010
+ default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals
+ ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable
+ DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable
+ DoAndIfThenElse EmptyDataDecls ExistentialQuantification
+ FlexibleContexts FlexibleInstances FunctionalDependencies GADTs
+ GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase
+ MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns
+ OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds
+ RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving
+ TupleSections TypeApplications TypeFamilies TypeSynonymInstances
+ UnicodeSyntax ViewPatterns
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ build-depends:
+ HTF >=0.13.2.5 && <0.14,
+ base >=4.7 && <5,
+ cornea -any,
+ lens >=4.16.1 && <4.17,
+ mtl >=2.2.2 && <2.3,
+ template-haskell >=2.13.0.0 && <2.14,
+ th-abstraction >=0.2.10.0 && <0.3,
+ transformers >=0.5.5.0 && <0.6
diff --git a/lib/Control/Monad/DeepError.hs b/lib/Control/Monad/DeepError.hs
new file mode 100644
index 0000000..9c797ed
--- /dev/null
+++ b/lib/Control/Monad/DeepError.hs
@@ -0,0 +1,28 @@
+module Control.Monad.DeepError where
+
+import Control.Monad.Error.Class (MonadError(throwError, catchError))
+
+import Data.DeepPrisms (DeepPrisms, hoist, retrieve)
+
+class (MonadError e m, DeepPrisms e e') => MonadDeepError e e' m where
+ throwHoist :: e' -> m a
+
+instance (MonadError e m, DeepPrisms e e') => MonadDeepError e e' m where
+ throwHoist =
+ throwError . hoist
+
+catchAt :: (MonadError e m, DeepPrisms e e') => (e' -> m a) -> m a -> m a
+catchAt handle ma =
+ catchError ma f
+ where
+ f e = maybe (throwError e) handle (retrieve e)
+
+hoistEither :: MonadDeepError e e' m => Either e' a -> m a
+hoistEither =
+ either throwHoist return
+
+hoistMaybe :: MonadDeepError e e' m => e' -> Maybe a -> m a
+hoistMaybe e' =
+ maybe (throwHoist e') return
+
+-- TODO derive multiple errors with HList + Generic
diff --git a/lib/Control/Monad/DeepState.hs b/lib/Control/Monad/DeepState.hs
new file mode 100644
index 0000000..b87ae25
--- /dev/null
+++ b/lib/Control/Monad/DeepState.hs
@@ -0,0 +1,25 @@
+module Control.Monad.DeepState where
+
+import qualified Control.Lens as Lens (set, view)
+import Control.Monad.State.Class (MonadState)
+import qualified Control.Monad.State.Class as MS (MonadState(get), modify)
+
+import Data.DeepLenses (DeepLenses(deepLens))
+
+class (MonadState s m, DeepLenses s s') => MonadDeepState s s' m where
+ get :: m s'
+ put :: s' -> m ()
+ state :: (s' -> m (a, s')) -> m a
+
+instance (MonadState s m, DeepLenses s s') => MonadDeepState s s' m where
+ get = Lens.view deepLens <$> MS.get
+ put = MS.modify . Lens.set deepLens
+ state f = do
+ s' <- get
+ ~(a, s'') <- f s'
+ put s''
+ return a
+
+gets :: MonadDeepState s s' m => (s' -> a) -> m a
+gets =
+ (<$> get)
diff --git a/lib/Data/DeepLenses.hs b/lib/Data/DeepLenses.hs
new file mode 100644
index 0000000..d0d9a2a
--- /dev/null
+++ b/lib/Data/DeepLenses.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.DeepLenses where
+
+import Control.Lens (Lens', makeClassy)
+import Control.Monad (join)
+import Data.List (zipWith)
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype (
+ ConstructorInfo(ConstructorInfo),
+ ConstructorVariant(RecordConstructor),
+ DatatypeInfo(datatypeCons, datatypeName),
+ reifyDatatype,
+ )
+import Language.Haskell.TH.Syntax (ModName(..), Name(Name), NameFlavour(NameQ, NameS, NameG), OccName(..))
+
+class DeepLenses e e' where
+ deepLens :: Lens' e e'
+
+data Field =
+ Field {
+ fieldName :: Name,
+ fieldType :: Type
+ }
+ deriving Show
+
+data DT =
+ DT {
+ dtName :: Name,
+ dtFields :: [Field]
+ }
+ deriving Show
+
+dataType :: Name -> Q DT
+dataType name = do
+ info <- reifyDatatype name
+ return $ DT (datatypeName info) (fields $ datatypeCons info)
+ where
+ fields [ConstructorInfo _ _ _ types _ (RecordConstructor names)] =
+ zipWith Field names types
+ fields _ =
+ []
+
+mkHoist :: TypeQ -> TypeQ -> BodyQ -> DecQ
+mkHoist _ _ body = do
+ (VarE name) <- [|deepLens|]
+ funD name [clause [] body []]
+
+deepLensesInstance :: TypeQ -> TypeQ -> BodyQ -> DecQ
+deepLensesInstance top local body =
+ instanceD (cxt []) (appT (appT [t|DeepLenses|] top) local) [mkHoist top local body]
+
+idLenses :: Name -> DecQ
+idLenses name =
+ deepLensesInstance nt nt body
+ where
+ nt = conT name
+ body = normalB [|id|]
+
+eligibleForDeepError :: Name -> Q Bool
+eligibleForDeepError tpe = do
+ (ConT name) <- [t|DeepLenses|]
+ isInstance name [ConT tpe, ConT tpe]
+
+modName :: NameFlavour -> Maybe ModName
+modName (NameQ mod') =
+ Just mod'
+modName (NameG _ _ mod') =
+ Just mod'
+modName _ =
+ Nothing
+
+sameModule :: NameFlavour -> NameFlavour -> Bool
+sameModule f1 f2 =
+ case (modName f1, modName f2) of
+ (Just a, Just b) | a == b -> True
+ _ -> False
+
+lensName :: Name -> Name -> ExpQ
+lensName (Name _ topFlavour) (Name (OccName n) lensFlavour) =
+ varE (Name (OccName (lensName' n)) flavour)
+ where
+ lensName' ('_' : t) = t
+ lensName' [] = []
+ lensName' a = a
+ flavour
+ | sameModule topFlavour lensFlavour = NameS
+ | otherwise = lensFlavour
+
+fieldLenses :: Name -> [Name] -> Field -> DecsQ
+fieldLenses top intermediate (Field name (ConT tpe)) = do
+ current <- deepLensesInstance (conT top) (conT tpe) (normalB body)
+ sub <- dataLensesIfEligible top (name : intermediate) tpe
+ return (current : sub)
+ where
+ compose = appE . appE [|(.)|] . lensName top
+ body = foldr compose (lensName top name) (reverse intermediate)
+fieldLenses _ _ _ =
+ return []
+
+dataLenses :: Name -> [Name] -> Name -> DecsQ
+dataLenses top intermediate local = do
+ (DT _ fields) <- dataType local
+ join <$> traverse (fieldLenses top intermediate) fields
+
+dataLensesIfEligible :: Name -> [Name] -> Name -> DecsQ
+dataLensesIfEligible top intermediate local = do
+ eligible <- eligibleForDeepError local
+ if eligible then dataLenses top intermediate local else return []
+
+lensesForMainData :: Name -> DecsQ
+lensesForMainData name = do
+ idL <- idLenses name
+ fields <- dataLenses name [] name
+ return (idL : fields)
+
+deepLenses :: Name -> DecsQ
+deepLenses name = do
+ lenses <- makeClassy name
+ err <- lensesForMainData name
+ return $ lenses ++ err
diff --git a/lib/Data/DeepPrisms.hs b/lib/Data/DeepPrisms.hs
new file mode 100644
index 0000000..e65e913
--- /dev/null
+++ b/lib/Data/DeepPrisms.hs
@@ -0,0 +1,132 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.DeepPrisms where
+
+import Control.Lens (Prism', makeClassyPrisms)
+import qualified Control.Lens as Lens (preview, review)
+import Control.Monad (join, (<=<))
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype (
+ ConstructorInfo(constructorName, constructorFields),
+ DatatypeInfo(datatypeCons, datatypeName),
+ reifyDatatype,
+ )
+import Language.Haskell.TH.Syntax (ModName(..), Name(Name), NameFlavour(NameQ, NameS, NameG), OccName(..))
+
+class DeepPrisms e e' where
+ prism :: Prism' e e'
+
+hoist :: DeepPrisms e e' => e' -> e
+hoist =
+ Lens.review prism
+
+retrieve :: DeepPrisms e e' => e -> Maybe e'
+retrieve =
+ Lens.preview prism
+
+data Ctor =
+ Ctor {
+ ctorName :: Name,
+ ctorTypes :: [Type]
+ }
+
+data SubError =
+ SubError {
+ seCtor :: Name,
+ seWrapped :: Name
+ }
+
+ctor :: ConstructorInfo -> Ctor
+ctor info = Ctor (constructorName info) (constructorFields info)
+
+data DT =
+ DT {
+ dtName :: Name,
+ dtCons :: [Ctor]
+ }
+
+dataType :: Name -> Q DT
+dataType name = do
+ info <- reifyDatatype name
+ return $ DT (datatypeName info) (ctor <$> datatypeCons info)
+
+mkHoist :: TypeQ -> TypeQ -> BodyQ -> DecQ
+mkHoist _ _ body = do
+ (VarE name) <- [|prism|]
+ funD name [clause [] body []]
+
+deepPrismsInstance :: TypeQ -> TypeQ -> BodyQ -> DecQ
+deepPrismsInstance top local body =
+ instanceD (cxt []) (appT (appT [t|DeepPrisms|] top) local) [mkHoist top local body]
+
+idInstance :: Name -> DecQ
+idInstance name =
+ deepPrismsInstance nt nt body
+ where
+ nt = conT name
+ body = normalB [|id|]
+
+eligibleForDeepError :: Name -> Q Bool
+eligibleForDeepError tpe = do
+ (ConT name) <- [t|DeepPrisms|]
+ isInstance name [ConT tpe, ConT tpe]
+
+subInstances :: Name -> [Name] -> Name -> DecsQ
+subInstances top intermediate local = do
+ (DT _ subCons) <- dataType local
+ join <$> traverse (deepInstancesIfEligible top intermediate) subCons
+
+modName :: NameFlavour -> Maybe ModName
+modName (NameQ mod') =
+ Just mod'
+modName (NameG _ _ mod') =
+ Just mod'
+modName _ =
+ Nothing
+
+sameModule :: NameFlavour -> NameFlavour -> Bool
+sameModule f1 f2 =
+ case (modName f1, modName f2) of
+ (Just a, Just b) | a == b -> True
+ _ -> False
+
+prismName :: Name -> Name -> ExpQ
+prismName (Name _ topFlavour) (Name (OccName n) prismFlavour) =
+ varE (Name (OccName ('_' : n)) flavour)
+ where
+ flavour
+ | sameModule topFlavour prismFlavour = NameS
+ | otherwise = prismFlavour
+
+deepInstances :: Name -> [Name] -> Name -> Name -> DecsQ
+deepInstances top intermediate name tpe = do
+ current <- deepPrismsInstance (conT top) (conT tpe) (normalB body)
+ sub <- subInstances top (name : intermediate) tpe
+ return (current : sub)
+ where
+ compose = appE . appE [|(.)|] . prismName top
+ body = foldr compose (prismName top name) intermediate
+
+deepInstancesIfEligible :: Name -> [Name] -> Ctor -> DecsQ
+deepInstancesIfEligible top intermediate (Ctor name [ConT tpe]) = do
+ eligible <- eligibleForDeepError tpe
+ if eligible then deepInstances top intermediate name tpe else return []
+deepInstancesIfEligible _ _ _ =
+ return []
+
+errorInstances :: DT -> DecsQ
+errorInstances (DT name cons) = do
+ idInst <- idInstance name
+ deepInsts <- traverse (deepInstancesIfEligible name []) cons
+ return (idInst : join deepInsts)
+
+deepPrisms' :: Name -> DecsQ
+deepPrisms' =
+ errorInstances <=< dataType
+
+deepPrisms :: Name -> DecsQ
+deepPrisms name = do
+ prisms <- makeClassyPrisms name
+ err <- deepPrisms' name
+ return $ prisms ++ err
diff --git a/test/u/DeepErrorSpec.hs b/test/u/DeepErrorSpec.hs
new file mode 100644
index 0000000..136a770
--- /dev/null
+++ b/test/u/DeepErrorSpec.hs
@@ -0,0 +1,62 @@
+{-# OPTIONS_GHC -F -pgmF htfpp #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module DeepErrorSpec(
+ htf_thisModulesTests,
+) where
+
+import Control.Monad.Trans.Except (runExceptT)
+import Test.Framework
+
+import Control.Monad.DeepError (MonadDeepError(throwHoist))
+import Data.DeepPrisms (deepPrisms)
+
+newtype Err1 =
+ Err1 Int
+ deriving (Eq, Show)
+
+newtype Err2 =
+ Err2 Int
+ deriving (Eq, Show)
+
+data Err =
+ ErrC Err1
+ |
+ ErrC1 Err2
+ deriving (Eq, Show)
+
+deepPrisms ''Err
+
+newtype MiddleOther =
+ MiddleOther Int
+ deriving (Eq, Show)
+
+data MiddleErr =
+ MiddleErrC Err
+ |
+ MiddleErrOther MiddleOther
+ deriving (Eq, Show)
+
+deepPrisms ''MiddleErr
+
+newtype MainOther =
+ MainOther Int
+ deriving (Eq, Show)
+
+data MainErr =
+ MainErrC MiddleErr
+ |
+ MainErrOther MainOther
+ deriving (Eq, Show)
+
+deepPrisms ''MainErr
+
+throwDeep :: MonadDeepError e Err m => m ()
+throwDeep =
+ throwHoist (ErrC (Err1 5))
+
+test_hoist :: IO ()
+test_hoist = do
+ -- traverse_ putStrLn $ lines $(stringE . pprint =<< deepPrisms ''MainErr)
+ a <- runExceptT throwDeep
+ assertEqual (Left (MainErrC (MiddleErrC (ErrC (Err1 5))))) a
diff --git a/test/u/DeepStateSpec.hs b/test/u/DeepStateSpec.hs
new file mode 100644
index 0000000..d6631ff
--- /dev/null
+++ b/test/u/DeepStateSpec.hs
@@ -0,0 +1,56 @@
+{-# OPTIONS_GHC -F -pgmF htfpp #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module DeepStateSpec(
+ htf_thisModulesTests,
+) where
+
+import Control.Monad.Trans.State (execStateT)
+import Test.Framework
+
+import Control.Monad.DeepState (MonadDeepState(get, put), gets)
+import Data.DeepLenses (deepLenses)
+
+newtype S1 =
+ S1 Int
+ deriving (Eq, Show)
+
+newtype S2 =
+ S2 Int
+ deriving (Eq, Show)
+
+newtype Bot =
+ BotC { _botS1 :: S1 }
+ deriving (Eq, Show)
+
+deepLenses ''Bot
+
+newtype MiddleOther =
+ MiddleOther Int
+ deriving (Eq, Show)
+
+data MiddleS =
+ MiddleSC {
+ _middleBot :: Bot,
+ _middleS2 :: S2
+ }
+ deriving (Eq, Show)
+
+deepLenses ''MiddleS
+
+newtype MainS =
+ MainSC { _mainMiddle :: MiddleS }
+ deriving (Eq, Show)
+
+deepLenses ''MainS
+
+stateDeep :: MonadDeepState s Bot m => m ()
+stateDeep = do
+ (BotC (S1 a)) <- get
+ b <- gets $ \(BotC (S1 b)) -> b
+ put (BotC (S1 (a + b + 3)))
+
+test_lens :: IO ()
+test_lens = do
+ a <- execStateT stateDeep (MainSC (MiddleSC (BotC (S1 5)) (S2 1)))
+ assertEqual (MainSC (MiddleSC (BotC (S1 13)) (S2 1))) a
diff --git a/test/u/SpecMain.hs b/test/u/SpecMain.hs
new file mode 100644
index 0000000..579a0ae
--- /dev/null
+++ b/test/u/SpecMain.hs
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -F -pgmF htfpp #-}
+
+module Main where
+
+import Test.Framework
+import Test.Framework.BlackBoxTest ()
+import {-@ HTF_TESTS @-} DeepErrorSpec
+import {-@ HTF_TESTS @-} DeepStateSpec
+
+main :: IO ()
+main = htfMain htf_importedTests