Write C-style enum in Haskell

README.md

The Haskell way to define C-style enum type.

An enumerator with = defines its enumeration constant as the value of the constant expression. If the first enumerator has no =, the value of its enumeration constant is 0. Each subsequent enumerator with no = defines its enumeration constant as the value of the constant expression obtained by adding 1 to the value of the previous enumeration constant. (The use of enumerators with = may produce enumeration constants with values that duplicate other values in the same enumeration.)

enum E {
    E0,
    E1,
    E2 = 3,
    E3,
    E4 = INT_MAX,
    /* Compile time error: Overflow in enumeration values */
    /*E5*/
};

/* If unspecified, the first is 0. */
assert(E0 == 0);
assert(E1 == 1);
assert(E2 == 3);
/* Continue from the last one. */
assert(E3 == 4);
assert(E4 == INT_MAX);

data E = E0
       | E1
       | E2_3
       | E3
       deriving Show

enum ''E

cenum.cabal

name:                cenum
version:             0.1.0.0
synopsis:            Simple project template from stack
description:         Please see README.md
homepage:            http://github.com/githubuser/cenum#readme
license:             BSD3
license-file:        LICENSE
author:              Author name here
maintainer:          example@example.com
copyright:           2010 Author Here
category:            Web
build-type:          Simple
cabal-version:       >=1.10

executable cenum
  hs-source-dirs:      .
  main-is:             Main.hs
  default-language:    Haskell2010
  build-depends:       base >= 4.7 && < 5
                     , regex-pcre
                     , template-haskell

CEnum.hs

{-# LANGUAGE ViewPatterns #-}

module CEnum where

import Data.Maybe          ( fromMaybe )
import Text.Read           ( readMaybe )
import Text.Regex.PCRE
import Language.Haskell.TH

normalCons :: Con -> Name
normalCons (NormalC n _) = n

getCons :: Info -> [Name]
getCons cons = case cons of
    TyConI (DataD    _ _ _ tcons _) -> map normalCons tcons
    con -> error $ "Can't derive for:" ++ show con

enum :: Name -> Q [Dec]
enum dt = do
  info <- reify dt
  Just cls <- lookupTypeName "Enum"
  let datatypeStr = nameBase dt
  let cons = patchIndexes $ getCons info
  let dtype = mkName datatypeStr
  let mkInstance fs ts =
        InstanceD
        []                              -- Context
        (AppT
          (ConT cls)                    -- Instance
          (ConT dtype))                 -- Head
        [ FunD (mkName "fromEnum") fs
        , FunD (mkName "toEnum") ts
        ]      -- Methods
  let fs = map genFromEnum cons
  let ts = map genToEnum cons
  return [mkInstance fs ts]

genFromEnum :: (Name, Integer) -> Clause
genFromEnum (n, i) = Clause [ConP n []] (NormalB (LitE (IntegerL i))) []

genToEnum :: (Name, Integer) -> Clause
genToEnum (n, i) = Clause [LitP (IntegerL i)] (NormalB (ConE n)) []

getIndex :: String -> Maybe Integer
getIndex ((=~ "^.*_('?)(\\d+)$") -> [[_, prefix, digits]]) = sign <$> readMaybe digits
  where sign = if null prefix then id else (0-)
getIndex _ = Nothing

patchIndexes :: [Name] -> [(Name, Integer)]
patchIndexes cons = patch' cons 0 []
  where
    patch' (c:cs) i rs = patch' cs (i'+1) ((c, i'):rs)
      where i' = fromMaybe i (getIndex (nameBase c))
    patch' [] _ rs = rs

LICENSE

Copyright  (c) 2015

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  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.

Main.hs

{-# LANGUAGE TemplateHaskell #-}

module Main where

import CEnum

data Status = NetworkError_'99
            | DiskError
            | Continue_100
            | SwitchingProto
            | Ok_200
            | Created
            | Accepted
            | NonAuth
            | NoContent
            | ResetContent
            | PartialContent
            | MultChoices_300
            | MovedPremanently
            | Found
            | SeeOther
            | NotModified
            | UseProxy
            | UnUsed
            | TemporaryRedirect
            | BadRequest_400
            | Unauthorized
            | PaymentRequired
            | Forbidden
            | NotFound
            | MethodNotAllowed
            | NotAcceptable
            deriving Show

enum ''Status

statuses = [ NetworkError_'99 , DiskError , Continue_100 , SwitchingProto , Ok_200 , Created , Accepted , NonAuth , NoContent , ResetContent , PartialContent , MultChoices_300 , MovedPremanently , Found , SeeOther , NotModified , UseProxy , UnUsed , TemporaryRedirect , BadRequest_400 , Unauthorized , PaymentRequired , Forbidden , NotFound , MethodNotAllowed , NotAcceptable ]

-- >>> enums
-- [(NetworkError_'99,-99),(DiskError,-98),(Continue_100,100),(SwitchingProto,101),(Ok_200,200),(Created,201),(Accepted,202),(NonAuth,203),(NoContent,204),(ResetContent,205),(PartialContent,206),(MultChoices_300,300),(MovedPremanently,301),(Found,302),(SeeOther,303),(NotModified,304),(UseProxy,305),(UnUsed,306),(TemporaryRedirect,307),(BadRequest_400,400),(Unauthorized,401),(PaymentRequired,402),(Forbidden,403),(NotFound,404),(MethodNotAllowed,405),(NotAcceptable,406)]
enums = map (\s -> (s, fromEnum s)) statuses

main :: IO ()
main = do
  print enums

Setup.hs

import Distribution.Simple
main = defaultMain

stack.yaml

# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md

# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
resolver: lts-3.11

# Local packages, usually specified by relative directory name
packages:
- '.'

# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
extra-deps: []

# Override default flag values for local packages and extra-deps
flags: {}

# Extra package databases containing global packages
extra-package-dbs: []

# Control whether we use the GHC we find on the path
# system-ghc: true

# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: >= 0.1.4.0

# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64

# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]