packages feed

exception-hierarchy (empty) → 0.0.0.1

raw patch · 5 files changed

+173/−0 lines, 5 filesdep +basedep +template-haskellsetup-changed

Dependencies added: base, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2015, Yoshikuni Jujo+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 the Yoshikuni Jujo nor the names of its+    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 EVEN SHALL THE COPYRIGHT HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,1 @@+import Distribution.Simple; main = defaultMain
+ exception-hierarchy.cabal view
@@ -0,0 +1,35 @@+build-type: Simple+cabal-version: >= 1.8++name: exception-hierarchy+version: 0.0.0.1+stability: Experimental+author: Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>+homepage: yet++license: BSD3+license-file: LICENSE++category: Language+synopsis: Exception type hierarchy with TemplateHaskell+description:+    see sample code in samples/++extra-source-files:+    samples/humanError.hs++source-repository head+    type: git+    location: git://github.com/YoshikuniJujo/test-haskell.git++source-repository this+    type: git+    location: git://github.com/YoshikuniJujo/test-haskell.git+    tag: exception-hierarchy-0.0.0.1++library+    hs-source-dirs: src+    exposed-modules: Control.Exception.Hierarchy+    build-depends: base == 4.*, template-haskell == 2.9.*+    ghc-options: -Wall
+ samples/humanError.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, ExistentialQuantification #-}++import Control.Exception+import Data.Typeable++import Control.Exception.Hierarchy++newtype GhostError = GhostError String deriving (Typeable, Show)+newtype MyException = MyException String deriving (Typeable, Show)+newtype ManError = ManError String deriving (Typeable, Show)+newtype WomanError = WomanError String deriving (Typeable, Show)+newtype WolfmanError = WolfmanError String deriving (Typeable, Show)+newtype MermaidError = MermaidError String deriving (Typeable, Show)++exceptionHierarchy Nothing (ExType ''MyException)+exceptionHierarchy Nothing (+	ExNode "HumanError" [+		ExType ''ManError, +		ExNode "DemihumanError" [],+		ExNode "NomanError" [+			ExType ''GhostError ] ] )++exceptionHierarchy (Just ''HumanError) (ExType ''WomanError)+exceptionHierarchy (Just ''DemihumanError) (ExType ''WolfmanError)++instance Exception MermaidError where+	toException = demihumanErrorToException+	fromException = demihumanErrorFromException
+ src/Control/Exception/Hierarchy.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TemplateHaskell #-}++module Control.Exception.Hierarchy (+	ExceptionHierarchy(..), exceptionHierarchy ) where++import Control.Applicative+import Control.Exception+import Data.Typeable+import Data.Char+import Language.Haskell.TH++data ExceptionHierarchy+	= ExNode String [ExceptionHierarchy]+	| ExType Name+	deriving Show++exceptionHierarchy :: Maybe Name -> ExceptionHierarchy -> DecsQ+exceptionHierarchy mc (ExNode e es) = (concat .) . (:)+	<$> exception1 mc (mkName e) True+	<*> mapM (exceptionHierarchy . Just $ mkName e) es+exceptionHierarchy mc (ExType e) = exception1 mc e False++exception1 :: Maybe Name -> Name -> Bool -> DecsQ+exception1 mc e c = (:)+	<$> maybe (defInstException e) (`instException` e) mc+	<*> if c then exceptionContainer e else return []++exceptionContainer :: Name -> DecsQ+exceptionContainer ec = sequence [+	dataD (cxt []) he []+		[forallC [PlainTV e] (cxt [classP ''Exception [varT e]]) $+			normalC he [strictType notStrict (varT e)]]+		[''Typeable],+	instanceD (cxt []) (conT ''Show `appT` conT he)+		[funD 'showsPrec+			[clause [varP d, conP he [varP e]]+				(normalB $ varE 'showsPrec `appE` varE d `appE` varE e) []]],+	sigD toEx . forallT [PlainTV e] (cxt [classP ''Exception [varT e]]) $+		varT e `arrT` conT ''SomeException,+	valD (varP toEx)+		(normalB $ infixE+			(Just $ varE 'toException) (varE '(.)) (Just $ conE he))+		[],+	sigD fromEx . forallT [PlainTV e] (cxt [classP ''Exception [varT e]]) $+		conT ''SomeException `arrT` (conT ''Maybe `appT` varT e),+	funD fromEx [clause+		[varP se]+		(normalB $ doE [+			bindS (conP he [varP e])+				(varE 'fromException `appE` varE se),+			noBindS $ varE 'cast `appE` varE e])+		[]]+	]+	where+	he = ec+	ec' = toLowerH $ nameBase ec+	toEx = mkName $ ec' ++ "ToException"+	fromEx = mkName $ ec' ++ "FromException"+	e = mkName "e"+	se = mkName "se"+	d = mkName "d"++defInstException :: Name -> DecQ+defInstException e = instanceD (cxt []) (conT ''Exception `appT` conT e) []++infixr `arrT`+arrT :: TypeQ -> TypeQ -> TypeQ+arrT t1 t2 = arrowT `appT` t1 `appT` t2++instException :: Name -> Name -> DecQ+instException ec e = instanceD (cxt [])+	(conT ''Exception `appT` conT e) [+		valD (varP $ mkName "toException") (normalB $ varE te) [],+		valD (varP $ mkName "fromException") (normalB $ varE fe) [] ]+	where+	ec' = toLowerH $ nameBase ec+	te = mkName $ ec' ++ "ToException"+	fe = mkName $ ec' ++ "FromException"++toLowerH :: String -> String+toLowerH (c : cs) = toLower c : cs+toLowerH _ = ""