packages feed

cornea (empty) → 0.2.0.0

raw patch · 10 files changed

+636/−0 lines, 10 filesdep +HTFdep +basedep +cornea

Dependencies added: HTF, base, cornea, lens, mtl, template-haskell, th-abstraction, transformers

Files

+ LICENSE view
@@ -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.***
+ README.md view
@@ -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))))+```
+ cornea.cabal view
@@ -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
+ lib/Control/Monad/DeepError.hs view
@@ -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
+ lib/Control/Monad/DeepState.hs view
@@ -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)
+ lib/Data/DeepLenses.hs view
@@ -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
+ lib/Data/DeepPrisms.hs view
@@ -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
+ test/u/DeepErrorSpec.hs view
@@ -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
+ test/u/DeepStateSpec.hs view
@@ -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
+ test/u/SpecMain.hs view
@@ -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