derive-is-data-con (empty) → 0.1.0.0
raw patch · 8 files changed
+338/−0 lines, 8 filesdep +HUnitdep +basedep +derive-is-data-consetup-changed
Dependencies added: HUnit, base, derive-is-data-con, template-haskell
Files
- CHANGELOG.md +11/−0
- LICENSE +26/−0
- README.md +66/−0
- Setup.hs +2/−0
- derive-is-data-con.cabal +58/−0
- src/Data/Derive/IsDataCon.hs +85/−0
- test/Cases.hs +79/−0
- test/Spec.hs +11/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `derive-is-data-con`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## 0.1.0.0 - 2025-02-19++Initial Release
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2025 Author name here++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder 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 EVENT 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.
+ README.md view
@@ -0,0 +1,66 @@+# derive-is-data-con++This package will generate data constructor predicate functions++```haskell+ derive_is ''Bool+ ======>+ isFalse :: Bool -> Bool+ isTrue :: Bool -> Bool+ isFalse False = True+ isFalse _ = False+ isTrue True = True+ isTrue _ = False+```++Above code will generate isTrue and isFalse functions. The function is 'is' + data constructor. ++For operators, there is a function that translates to string++```haskell+charToString :: Char -> String+charToString '~' = "Tilde"+charToString '!' = "Bang"+charToString '@' = "At"+charToString '#' = "Hash"+charToString '$' = "Dollar"+charToString '%' = "Percent"+charToString '^' = "Caret"+charToString '&' = "And"+charToString '*' = "Star"+charToString '-' = "Minus"+charToString '+' = "Plus"+charToString '=' = "Equal"+charToString '|' = "Pipe"+charToString '\\' = "Backslash"+charToString '/' = "Slash"+charToString '<' = "Lt"+charToString '>' = "Gt"+charToString ':' = "Colon"+charToString '?' = "Question"+charToString '.' = "Dot"+-- charToString '[' = "LSquareBracket" -- I do not want to support derive_is ''[]. One should use null function instead.+-- charToString ']' = "RSquareBracket"+```++For example `(:=:)` will be translated into `isColonStarColon` function++For gadt data type++```haskell+data Gadt a b where+ (:*:), (:=:) :: a -> b -> Gadt a b+```++The following code will be generated:++```haskell+ derive_is ''Gadt + ======>+ isColonStarColon :: Gadt a_a54E a_a54F -> Bool+ isColonEqualColon :: Gadt a_a54G a_a54H -> Bool+ isColonStarColon ((:*:) _ _) = True+ isColonStarColon _ = False+ isColonEqualColon ((:=:) _ _) = True+ isColonEqualColon _ = False+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ derive-is-data-con.cabal view
@@ -0,0 +1,58 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name: derive-is-data-con+version: 0.1.0.0+synopsis: This package generates data constructor predicate functions+description: Please see the README on GitHub at <https://github.com/HaskellZhangSong/derive-is-data-con#readme>+category: Development+homepage: https://github.com/HaskellZhangSong/derive-is-data-con#readme+bug-reports: https://github.com/HaskellZhangSong/derive-is-data-con/issues+author: Zhang Song+maintainer: Haskell.Zhang.Song `at` hotmail.com+copyright: 2025 Zhang Song+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/HaskellZhangSong/derive-is-data-con++library+ exposed-modules:+ Data.Derive.IsDataCon+ other-modules:+ Paths_derive_is_data_con+ autogen-modules:+ Paths_derive_is_data_con+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , template-haskell+ default-language: Haskell2010++test-suite derive-is-data-con-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Cases+ Paths_derive_is_data_con+ autogen-modules:+ Paths_derive_is_data_con+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HUnit+ , base >=4.7 && <5+ , derive-is-data-con+ default-language: Haskell2010
+ src/Data/Derive/IsDataCon.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+module Data.Derive.IsDataCon (+ derive_is+ ) +where++import Language.Haskell.TH+import Control.Monad++type TypeName = Name+type ConName = Name++nameToFunc :: ConName -> Int -> Dec+nameToFunc name numOfTyArg = FunD fname [isClause, defaultClause]+ where+ fname = mkName $ "is" ++ ((if (isNameOp name) then (infixToStringName . mkName) else id) $ nameBase name)+#if __GLASGOW_HASKELL__ >= 902+ isClause = Clause [ConP name [] (replicate numOfTyArg WildP)] (NormalB (ConE 'True)) []+#else+ isClause = Clause [ConP name (replicate numOfTyArg WildP)] (NormalB (ConE 'True)) []+#endif+ defaultClause = Clause [WildP] (NormalB (ConE 'False)) []++infixToStringName :: Name -> String+infixToStringName name = (concatMap charToString (nameBase name))++isNameOp :: Name -> Bool+isNameOp n = elem (head (nameBase n)) "~!@#$%^&*-+=|\\/<>:?.[]"++charToString :: Char -> String+charToString '~' = "Tilde"+charToString '!' = "Bang"+charToString '@' = "At"+charToString '#' = "Hash"+charToString '$' = "Dollar"+charToString '%' = "Percent"+charToString '^' = "Caret"+charToString '&' = "And"+charToString '*' = "Star"+charToString '-' = "Minus"+charToString '+' = "Plus"+charToString '=' = "Equal"+charToString '|' = "Pipe"+charToString '\\' = "Backslash"+charToString '/' = "Slash"+charToString '<' = "Lt"+charToString '>' = "Gt"+charToString ':' = "Colon"+charToString '?' = "Question"+charToString '.' = "Dot"+charToString x = error $ show x ++ " is not a valid operator symbol"++conToIsFunc :: Con -> [Dec]+conToIsFunc (NormalC name ts) = [nameToFunc name (length ts)]+conToIsFunc (RecC name vbts) = [nameToFunc name (length vbts)]+conToIsFunc (InfixC _ name _) = [nameToFunc name 2]+conToIsFunc (ForallC _ _ con) = conToIsFunc con+conToIsFunc (GadtC ns ts _) = map (uncurry nameToFunc) [(n, length ts) | n <- ns]+conToIsFunc (RecGadtC ns ts _) = map (uncurry nameToFunc) [(n, length ts) | n <- ns]++nameToSig :: ConName -> TypeName -> Int -> Q [Dec]+nameToSig fn tn tnNumOfVars = do+ ns <- replicateM tnNumOfVars (newName "a")+ let vars = map VarT ns+ let fname = mkName $ "is" ++ ((if (isNameOp fn) then (infixToStringName . mkName) else id) $ nameBase fn)+ return [SigD fname (AppT (AppT ArrowT (foldl AppT (ConT tn) vars)) (ConT ''Bool))]++conToSig :: TypeName -> Int -> Con -> Q [Dec]+conToSig tn numOfTyVars (NormalC name _) = nameToSig name tn numOfTyVars+conToSig tn numOfTyVars (RecC name _) = nameToSig name tn numOfTyVars+conToSig tn numOfTyVars (InfixC _ name _) = nameToSig name tn numOfTyVars+conToSig tn numOfTyVars (ForallC _ _ con) = conToSig tn numOfTyVars con+conToSig tn numOfTyVars (GadtC ns _ _) = fmap concat $ mapM (\fn -> nameToSig fn tn numOfTyVars) ns+conToSig tn numOfTyVars (RecGadtC ns _ _) = fmap concat $ mapM (\fn -> nameToSig fn tn numOfTyVars) ns++derive_is :: Name -> Q [Dec]+derive_is name = do+ info <- reify name+ case info of+ TyConI (DataD _ _ tvbs _ cons _) -> do + sigs <- fmap concat $ mapM (conToSig name (length tvbs)) cons+ let defs = concatMap conToIsFunc cons+ return $ sigs ++ defs+ i -> error $ show i ++ " is not data type"
+ test/Cases.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-partial-fields #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module Cases(+ bool, maybe', either', op, gadtOp, recTest+) where++import Test.HUnit+import Data.Derive.IsDataCon++derive_is ''Bool++bool :: Test+bool = TestList [+ TestCase (assertEqual "False is False" (isFalse False) True)+ , TestCase (assertEqual "True is True" (isTrue True) True)+ , TestCase (assertEqual "False is not True" (isFalse True) False)+ , TestCase (assertEqual "True is not False" (isTrue False) False)+ ]++derive_is ''Maybe++maybe' :: Test+maybe' = TestList [+ TestCase (assertEqual "Nothing is Nothing" (isNothing Nothing) True)+ , TestCase (assertEqual "Nothing is Nothing" (isJust (Just ())) True)+ , TestCase (assertEqual "Nothing is not Just" (isNothing (Just ())) False)+ , TestCase (assertEqual "Just is not Nothing" (isJust Nothing) False)]++derive_is ''Either++either' :: Test+either' = TestList [+ TestCase (assertEqual "Left is Left" (isLeft (Left ())) True)+ , TestCase (assertEqual "Right is Right" (isRight (Right ())) True)+ , TestCase (assertEqual "Left is not Right" (isLeft (Right ())) False)+ , TestCase (assertEqual "Right is not Left" (isRight (Left ())) False)]++data (:-:) a b = (:-:) a b | (:=) a b+derive_is ''(:-:)++op :: Test+op = TestList [+ TestCase (assertEqual "ColonMinusColon is ColonMinusColon" (isColonMinusColon ((:-:) () ())) True)+ , TestCase (assertEqual "ColonEqual is ColonEqual" (isColonEqual ( () := ())) True)+ , TestCase (assertEqual "ColonMinusColon is not ColonEqual" (isColonMinusColon ((:=) () ())) False)+ , TestCase (assertEqual "ColonEqual is not ColonMinusColon" (isColonEqual (() :-: ())) False)]+++data Gadt a b where+ (:*:), (:=:) :: a -> b -> Gadt a b++derive_is ''Gadt++gadtOp :: Test+gadtOp = TestList [+ TestCase (assertEqual "ColonStarColon is ColonStarColon" (isColonStarColon ((:*:) () ())) True)+ , TestCase (assertEqual "ColonEqualColon is ColonEqualColon" (isColonEqualColon ( () :=: ())) True)+ , TestCase (assertEqual "ColonStarColon is not ColonEqual" (isColonStarColon ((:=:) () ())) False)+ , TestCase (assertEqual "ColonEqualColon is not ColonStarColon" (isColonEqualColon (() :*: ())) False)]++data Rec a b c = A { getA :: a } | B { getB :: b } | C { getC :: c}++derive_is ''Rec++recTest :: Test+recTest = TestList [+ TestCase (assertEqual "A is A" (isA (A ())) True)+ , TestCase (assertEqual "B is B" (isB (B ())) True)+ , TestCase (assertEqual "C is C" (isC (C ())) True)+ , TestCase (assertEqual "B is not A" (isA (B ())) False)+ , TestCase (assertEqual "C is not A" (isA (C ())) False)+ , TestCase (assertEqual "A is not B" (isB (A ())) False)+ , TestCase (assertEqual "C is not B" (isB (C ())) False)+ , TestCase (assertEqual "A is not C" (isC (A ())) False)+ , TestCase (assertEqual "B is not C" (isC (B ())) False)+ ]
+ test/Spec.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}++import Test.HUnit+import Cases++listTests :: [Test]+listTests = [bool, maybe', either', op, gadtOp, recTest]++main :: IO ()+main = mapM_ runTestTT listTests