{-# Language BlockArguments #-}
module Advent.Format.Enum where

import Language.Haskell.TH
import Data.List
import Data.Traversable

enumCases :: String -> Q [(Name,String)]
enumCases :: [Char] -> Q [(Name, [Char])]
enumCases [Char]
nameStr =
 do tyName <- Q Name -> (Name -> Q Name) -> Maybe Name -> Q Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Q Name
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Failed to find type named " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
nameStr)) Name -> Q Name
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
           (Maybe Name -> Q Name) -> Q (Maybe Name) -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Q (Maybe Name)
lookupTypeName [Char]
nameStr

    info <- reify tyName
    cons <-
      case info of
        TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ [Con]
cons [DerivClause]
_) -> [Con] -> Q [Con]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Con]
cons
        Info
_ -> [Char] -> Q [Con]
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Failed to find data declaration for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
nameStr)

    for cons \Con
con ->
      case Con
con of
        NormalC Name
name []
          | Just [Char]
str <- [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
nameStr (Name -> [Char]
nameBase Name
name) ->
            case [Char]
str of
              Char
'_' : [Char]
symbolName ->
                do symbol <- [Char] -> Q [Char]
processSymbolName [Char]
symbolName
                   pure (name, symbol)
              [Char]
_ -> (Name, [Char]) -> Q (Name, [Char])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, [Char]
str)
        Con
_ -> [Char] -> Q (Name, [Char])
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Unsupported constructor: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Con -> [Char]
forall a. Show a => a -> [Char]
show Con
con)

processSymbolName :: String -> Q String
processSymbolName :: [Char] -> Q [Char]
processSymbolName [Char]
str =
  case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
'_' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) [Char]
str of
    ([Char]
name, [Char]
rest) ->
      case [Char] -> [([Char], Char)] -> Maybe Char
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
name [([Char], Char)]
symbolNames of
        Maybe Char
Nothing -> [Char] -> Q [Char]
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Unknown symbol name: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name)
        Just Char
symbol ->
          case [Char]
rest of
            [] -> [Char] -> Q [Char]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char
symbol]
            Char
_:[Char]
str' -> (Char
symbolChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> Q [Char] -> Q [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Q [Char]
processSymbolName [Char]
str'

symbolNames :: [(String, Char)]
symbolNames :: [([Char], Char)]
symbolNames =
  [ ([Char]
"LT", Char
'<')
  , ([Char]
"GT", Char
'>')
  , ([Char]
"EQ", Char
'=')
  , ([Char]
"BANG", Char
'!')
  , ([Char]
"AT" , Char
'@')
  , ([Char]
"HASH", Char
'#')
  , ([Char]
"DOLLAR", Char
'$')
  , ([Char]
"PERCENT", Char
'%')
  , ([Char]
"CARET", Char
'^')
  , ([Char]
"AMPERSAND", Char
'&')
  , ([Char]
"STAR", Char
'*')
  , ([Char]
"PIPE", Char
'|')
  , ([Char]
"LPAREN", Char
'(')
  , ([Char]
"RPAREN", Char
')')
  , ([Char]
"LBRACE", Char
'{')
  , ([Char]
"RBRACE", Char
'}')
  , ([Char]
"LBRACK", Char
'[')
  , ([Char]
"RBRACK", Char
']')
  , ([Char]
"COLON", Char
':')
  , ([Char]
"SEMI", Char
';')
  , ([Char]
"QUESTION", Char
'?')
  , ([Char]
"SLASH", Char
'/')
  , ([Char]
"BACKSLASH", Char
'\\')
  , ([Char]
"UNDERSCORE", Char
'_')
  , ([Char]
"DASH", Char
'-')
  , ([Char]
"DOT", Char
'.')
  , ([Char]
"COMMA", Char
',')
  , ([Char]
"PLUS", Char
'+')
  , ([Char]
"TILDE", Char
'~')
  ]