c-enum (empty) → 0.1.0.0

raw patch · 7 files changed

+281/−0 lines, 7 filesdep +basedep +c-enumdep +template-haskellsetup-changed

Dependencies added: base, c-enum, template-haskell

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +49/−0
Setup.hs +2/−0
c-enum.cabal +52/−0
src/Foreign/C/Enum.hs +143/−0
test/Spec.hs +2/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for c-enum++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Yoshikuni Jujo (c) 2021++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 Yoshikuni Jujo 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.

+ README.md view

@@ -0,0 +1,49 @@+# c-enum++foo.h++```c+#ifndef _FOO_H+#define _FOO_H++typedef enum { FOO_ERROR = - 1, FOO_ZERO, FOO_ONE, FOO_TWO, FOO_THREE } Foo;++#endif+```++Foo.hsc++```haskell+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Foo where++import Foreign.C.Enum++#include "foo.h"++enum "Foo" ''#{type Foo} [''Show, ''Read, ''Eq] [+	("FooError", #{const FOO_ERROR}),+	("FooZero", #{const FOO_ZERO}),+	("FooOne", #{const FOO_ONE}),+	("FooTwo", #{const FOO_TWO}),+	("FooThree", #{const FOO_THREE}) ]+```++You get patterns FooError, ..., FooThree.+And `instance Show Foo` and `instance Read Foo` like the following.++```+> FooOne+FooOne+> Foo 1+FooOne+> Foo 5+Foo 5+> read "FooTwo" :: Foo+FooTwo+> read "Foo 3" :: Foo+FooThree+```

+ Setup.hs view

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

+ c-enum.cabal view

@@ -0,0 +1,52 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 6193eeddda031a2998034fae776898c57ad4ef04b7de0f07a6bb1db2721bf951++name:           c-enum+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/c-enum#readme>+homepage:       https://github.com/YoshikuniJujo/c-enum#readme+bug-reports:    https://github.com/YoshikuniJujo/c-enum/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo.pc@gmail.com+copyright:      2021 Yoshikuni Jujo+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/c-enum++library+  exposed-modules:+      Foreign.C.Enum+  other-modules:+      Paths_c_enum+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , template-haskell+  default-language: Haskell2010++test-suite c-enum-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_c_enum+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , c-enum+    , template-haskell+  default-language: Haskell2010

+ src/Foreign/C/Enum.hs view

@@ -0,0 +1,143 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Foreign.C.Enum (enum) where++import Language.Haskell.TH (+	Name, mkName, newName, Lit(..), clause, cxt, normalB,+	DecsQ, DecQ, valD, funD, instanceD,+	patSynSigD, patSynD, prefixPatSyn, explBidir,+	newtypeD, normalC, derivClause,+	ExpQ, varE, conE, litE, appE, infixE, listE, lamCaseE,+	conT, appT, varP, conP, litP, match,+	doE, bindS, noBindS,+	bangType, bang, noSourceUnpackedness, noSourceStrictness )+import Control.Arrow (first)+import Data.Bool (bool)+import Data.Maybe (isJust, listToMaybe)+import Data.List (partition)+import Text.Read (readPrec, Lexeme(..), step, choice, prec, parens, lexP)++enum :: String -> Name -> [Name] -> [(String, Integer)] -> DecsQ+enum nt t ds nvs = (\n s r ms -> n : s (r ms))+	<$> mkNewtype nt t ds'+	<*> bool (pure id) ((:) <$> mkShow nt ns) bs+	<*> bool (pure id) ((:) <$> mkRead nt ns) br+	<*> mkMembers nt nvs+	where ShowReadClasses bs br ds' = showReadClasses ds; ns = fst <$> nvs++{- ^++Write like the following.++@+enum Foo ''Int [''Show, ''Read, ''Eq] [+	("FooError", - 1),+	("FooZero", 0),+	("FooOne", 1),+	("FooTwo", 2) ]+@++Then you get like the following.++@+newtype Foo = Foo Int deriving Eq++pattern FooError :: Int -> Foo+pattern FooError <- Foo (- 1) where+	FooError = Foo (- 1)++pattern FooZero :: Int -> Foo+...+++instance Show Foo where+	showsPrec = ...++instance Read Foo where+	readPrec = ...+@++And you can read and show like the following.++@+> Foo $ - 1+FooError+> FooTwo+FooTwo+> Foo 3+Foo 3+> read "Foo (- 1)" :: Foo+FooError+> read \"FooOne\" :: Foo+FooOne+@++-}++data ShowReadClasses = ShowReadClasses {+	showReadClassesShow :: Bool,+	showReadClassesRead :: Bool,+	showReadClassesClasses :: [Name] } deriving Show++showReadClasses :: [Name] -> ShowReadClasses+showReadClasses ns = ShowReadClasses (isJust s) (isJust r) ns''+	where (s, ns') = popIt ''Show ns; (r, ns'') = popIt ''Read ns'++popIt :: Eq a => a -> [a] -> (Maybe a, [a])+popIt x = (listToMaybe `first`) . partition (== x)++mkNewtype :: String -> Name -> [Name] -> DecQ+mkNewtype nt t ds = newtypeD (cxt []) (mkName nt) [] Nothing+	(normalC (mkName nt)+		[bangType+			(bang noSourceUnpackedness noSourceStrictness)+			(conT t)])+	[derivClause Nothing $ conT <$> ds]++mkMembers :: String -> [(String, Integer)] -> DecsQ+mkMembers t nvs = concat <$> uncurry (mkMember (mkName t)) `mapM` nvs++mkMember :: Name -> String -> Integer -> DecsQ+mkMember t n v = sequence [+	patSynSigD (mkName n) (conT t),+	patSynD (mkName n) (prefixPatSyn [])+		(explBidir [flip (clause []) []+			. normalB $ conE t `appE` litE (IntegerL v)])+		(conP t [litP (IntegerL v)]) ]++mkShow :: String -> [String] -> DecQ+mkShow t ns = instanceD (cxt [])+	(conT ''Show `appT` conT (mkName t)) [defineShowsPrec t ns]++defineShowsPrec :: String -> [String] -> DecQ+defineShowsPrec t ns = newName `mapM` ["d", "n"] >>= \[d, n] ->+	funD 'showsPrec [clause [varP d] (normalB (lamCaseE (+		(named <$> ns) +++		[match (conP (mkName t) [varP n]) (normalB $ sw d n) []] ))) []]+	where+	named f = flip (match $ conP (mkName f) []) [] +		. normalB $ litE (StringL f) `p` varE '(++)+	sw d n = varE 'showParen `appE` (varE d .> litE (IntegerL 10))+		.$ ((litE (StringL $ t ++ " ") `p` varE '(++)) ...+			(varE 'showsPrec `appE` litE (IntegerL 11) `appE` varE n))++mkRead :: String -> [String] -> DecQ+mkRead t ns = instanceD (cxt []) (conT ''Read `appT` conT (mkName t)) . (: [])+	$ valD (varP 'readPrec) (normalB $ varE 'parens .$ (varE 'choice `appE` listE (+		(named <$> ns) +++		[varE 'prec `appE` litE (IntegerL 10) `appE` doE [+			bindS (conP 'Ident [litP $ StringL t]) $ varE 'lexP,+			noBindS $ conE (mkName t) .<$> (varE 'step `appE` varE 'readPrec) ]]+		))) []+	where+	named n = doE [+		bindS (conP 'Ident [litP $ StringL n]) $ varE 'lexP,+		noBindS $ varE 'pure `appE` conE (mkName n) ]++(...), (.$), (.<$>), (.>), p :: ExpQ -> ExpQ -> ExpQ+e1 ... e2 = infixE (Just e1) (varE '(.)) (Just e2)+e1 .$ e2 = infixE (Just e1) (varE '($)) (Just e2)+e1 .<$> e2 = infixE (Just e1) (varE '(<$>)) (Just e2)+e1 .> e2 = infixE (Just e1) (varE '(>)) (Just e2)+ex `p` op = infixE (Just ex) op Nothing

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"