haskell-src-exts-prisms (empty) → 1.18.2.0

raw patch · 5 files changed

+214/−0 lines, 5 filesdep +basedep +haskell-src-extsdep +lenssetup-changed

Dependencies added: base, haskell-src-exts, lens, template-haskell

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• haskell-src-exts-prisms.cabal +26/−0
• src/Language/Haskell/Exts/Prisms.hs +71/−0
• src/Language/Haskell/Exts/TypeList.hs +85/−0

@@ -0,0 +1,30 @@+Copyright Daniel Waterworth (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Daniel Waterworth nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,26 @@+name:                haskell-src-exts-prisms+version:             1.18.2.0+synopsis:            Prisms with newtype wrappers for haskell-src-exts+homepage:            https://github.com/DanielWaterworth/haskell-src-exts-prisms+license:             BSD3+license-file:        LICENSE+author:              Daniel Waterworth+maintainer:          da.waterworth@gmail.com+copyright:           2016 Daniel Waterworth+category:            Language+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Language.Haskell.Exts.Prisms+  other-modules:       Language.Haskell.Exts.TypeList+  build-depends:       base >= 4.7 && < 5+                     , haskell-src-exts == 1.18.2+                     , template-haskell >= 2.11 && < 2.12+                     , lens >= 4.14 && < 4.15+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/DanielWaterworth/haskell-src-exts-prisms

@@ -0,0 +1,71 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module Language.Haskell.Exts.Prisms where++import Language.Haskell.Exts.Syntax++import Data.List (foldl')++import Control.Monad+import Control.Applicative++import Control.Lens (makeWrapped, Prism', _Unwrapped)+import Control.Lens.TH++import qualified Language.Haskell.TH as TH++import Language.Haskell.Exts.TypeList++concat <$> mapM makePrisms types++$(concat <$>+  forM types (\name -> do+    TH.TyConI (TH.DataD _ _ binders Nothing constructors deriv) <- TH.reify name+    if length constructors >= 2 then+      forM constructors (\(TH.NormalC name tys) -> do+        let name' = TH.mkName $ "C_" ++ TH.nameBase name+        let ty = foldl' TH.AppT (TH.TupleT $ length tys) $ map snd tys+        let unbanged = TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness+        return $ TH.NewtypeD [] name' binders Nothing (TH.NormalC name' [(unbanged, ty)]) deriv)+     else+      return []))++$(concat <$>+  forM types (\name -> do+    TH.TyConI (TH.DataD _ _ binders Nothing constructors deriv) <- TH.reify name+    if length constructors >= 2 then+      concat <$>+        forM constructors (\(TH.NormalC name tys) -> do+          Just name' <- TH.lookupTypeName $ "C_" ++ TH.nameBase name+          makeWrapped name')+    else+      return []))++$(concat <$>+  forM types (\tName -> do+    TH.TyConI (TH.DataD _ _ binders Nothing constructors deriv) <- TH.reify tName+    if length constructors >= 2 then+      concat <$>+        forM constructors (\(TH.NormalC cName tys) -> do+          Just ty <- TH.lookupTypeName $ "C_" ++ TH.nameBase cName+          Just prismTy <- TH.lookupTypeName "Prism'"+          Just compose <- TH.lookupValueName "."+          Just unwrapped <- TH.lookupValueName "_Unwrapped"+          Just prism <- TH.lookupValueName $ "_" ++ TH.nameBase cName++          let name' = TH.mkName $ "_" ++ TH.nameBase cName ++ "'"+          vars <- replicateM (length binders) $ TH.newName "v"+          let f x = foldl' TH.AppT x $ map TH.VarT vars+          let baseTy = f $ TH.ConT tName+          let cTy = f $ TH.ConT ty+          let binding = TH.SigD name' $ TH.ConT prismTy `TH.AppT` baseTy `TH.AppT` cTy+          let exp = TH.ParensE (TH.VarE compose) `TH.AppE` TH.VarE prism `TH.AppE` TH.VarE unwrapped+          let v = TH.ValD (TH.VarP name') (TH.NormalB exp) []+          return [binding, v])+    else+      return []))

@@ -0,0 +1,85 @@+{-# LANGUAGE TemplateHaskell #-}++module Language.Haskell.Exts.TypeList where++import Language.Haskell.Exts.Syntax++types = [+    ''Module,+    ''ModuleHead,+    ''WarningText,+    ''ExportSpecList,+    ''ExportSpec,+    ''EWildcard,+    ''ImportDecl,+    ''ImportSpecList,+    ''ImportSpec,+    ''Assoc,+    ''Namespace,+    ''Decl,+    ''DeclHead,+    ''InstRule,+    ''InstHead,+    ''Binds,+    ''IPBind,+    ''PatternSynDirection,+    ''InjectivityInfo,+    ''ResultSig,+    ''ClassDecl,+    ''InstDecl,+    ''Deriving,+    ''DataOrNew,+    ''ConDecl,+    ''FieldDecl,+    ''QualConDecl,+    ''GadtDecl,+    ''BangType,+    ''Unpackedness,+    ''Match,+    ''Rhs,+    ''GuardedRhs,+    ''Context,+    ''FunDep,+    ''Asst,+    ''Type,+    ''Boxed,+    ''Kind,+    ''TyVarBind,+    ''Promoted,+    ''TypeEqn,+    ''Exp,+    ''Stmt,+    ''QualStmt,+    ''FieldUpdate,+    ''Alt,+    ''XAttr,+    ''Pat,+    ''PatField,+    ''PXAttr,+    ''RPat,+    ''RPatOp,+    ''Literal,+    ''Sign,+    ''ModuleName,+    ''QName,+    ''Name,+    ''QOp,+    ''Op,+    ''SpecialCon,+    ''CName,+    ''IPName,+    ''XName,+    ''Role,+    ''Bracket,+    ''Splice,+    ''Safety,+    ''CallConv,+    ''ModulePragma,+    ''Tool,+    ''Overlap,+    ''Rule,+    ''RuleVar,+    ''Activation,+    ''Annotation,+    ''BooleanFormula+  ]