diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell-src-exts-prisms.cabal b/haskell-src-exts-prisms.cabal new file mode 100644 --- /dev/null +++ b/haskell-src-exts-prisms.cabal @@ -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 diff --git a/src/Language/Haskell/Exts/Prisms.hs b/src/Language/Haskell/Exts/Prisms.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Exts/Prisms.hs @@ -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 [])) diff --git a/src/Language/Haskell/Exts/TypeList.hs b/src/Language/Haskell/Exts/TypeList.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Exts/TypeList.hs @@ -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 + ]