{-# LANGUAGE TemplateHaskell            #-}

-- | A tool to generate maps to and from 'Text' values corresponding
-- to inhabitants of enumerated types
module Data.API.Tools.Enum
    ( enumTool
    , text_enum_nm
    , map_enum_nm
    ) where

import           Data.API.TH
import           Data.API.Tools.Combinators
import           Data.API.Tools.Datatypes
import           Data.API.Types

import qualified Data.Text                      as T
import qualified Data.Map                       as Map
import           Language.Haskell.TH


-- | Tool to generate the maps between enumerations and 'Text' strings
-- named by 'text_enum_nm' and 'map_enum_nm'.
enumTool :: APITool
enumTool :: APITool
enumTool = Tool APINode -> APITool
apiNodeTool (Tool APINode -> APITool) -> Tool APINode -> APITool
forall a b. (a -> b) -> a -> b
$ Tool (APINode, SpecNewtype)
-> Tool (APINode, SpecRecord)
-> Tool (APINode, SpecUnion)
-> Tool (APINode, SpecEnum)
-> Tool (APINode, APIType)
-> Tool APINode
apiSpecTool Tool (APINode, SpecNewtype)
forall a. Monoid a => a
mempty Tool (APINode, SpecRecord)
forall a. Monoid a => a
mempty Tool (APINode, SpecUnion)
forall a. Monoid a => a
mempty Tool (APINode, SpecEnum)
enum Tool (APINode, APIType)
forall a. Monoid a => a
mempty
  where
    enum :: Tool (APINode, SpecEnum)
enum = ((APINode, SpecEnum) -> Q [Dec]) -> Tool (APINode, SpecEnum)
forall a. (a -> Q [Dec]) -> Tool a
simpleTool ((APINode -> SpecEnum -> Q [Dec]) -> (APINode, SpecEnum) -> Q [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry APINode -> SpecEnum -> Q [Dec]
gen_se_tx) Tool (APINode, SpecEnum)
-> Tool (APINode, SpecEnum) -> Tool (APINode, SpecEnum)
forall a. Semigroup a => a -> a -> a
<> ((APINode, SpecEnum) -> Q [Dec]) -> Tool (APINode, SpecEnum)
forall a. (a -> Q [Dec]) -> Tool a
simpleTool (APINode -> Q [Dec]
gen_se_mp (APINode -> Q [Dec])
-> ((APINode, SpecEnum) -> APINode)
-> (APINode, SpecEnum)
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (APINode, SpecEnum) -> APINode
forall a b. (a, b) -> a
fst)


-- | For an enum type @E@, name a function @_text_E :: E -> 'Text'@
-- that gives a string corresponding to the inhabitant of the type.
-- For example, we generate something like this:
--
-- >   _text_FrameRate :: FrameRate -> T.Text
-- >   _text_FrameRate fr =
-- >           case fr of
-- >             FRauto    -> "auto"
-- >             FR10      -> "10"
-- >             FR15      -> "15"
-- >             FR23_97   -> "23.97"
-- >             FR24      -> "24"
-- >             FR25      -> "25"
-- >             FR29_97   -> "29.97"
-- >             FR30      -> "30"
-- >             FR60      -> "60"

text_enum_nm :: APINode -> Name
text_enum_nm :: APINode -> Name
text_enum_nm APINode
an = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"_text_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (TypeName -> Text
_TypeName (TypeName -> Text) -> TypeName -> Text
forall a b. (a -> b) -> a -> b
$ APINode -> TypeName
anName APINode
an)

gen_se_tx :: APINode -> SpecEnum -> Q [Dec]
gen_se_tx :: APINode -> SpecEnum -> Q [Dec]
gen_se_tx APINode
as SpecEnum
se = Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD (APINode -> Name
text_enum_nm APINode
as)
                             [t| $TypeQ
tc -> T.Text |]
                             ExpQ
bdy
  where
    tc :: TypeQ
tc  = Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ APINode -> Name
rep_type_nm APINode
as

    bdy :: ExpQ
bdy  = [Q Match] -> ExpQ
forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE [ Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (FieldName -> Q Pat
pt FieldName
fnm) (FieldName -> Q Body
forall {m :: * -> *}. Quote m => FieldName -> m Body
bd FieldName
fnm) []
                    | (FieldName
fnm,String
_) <- SpecEnum -> [(FieldName, String)]
seAlts SpecEnum
se ]

    pt :: FieldName -> Q Pat
pt FieldName
fnm = APINode -> FieldName -> [Q Pat] -> Q Pat
nodeAltConP APINode
as FieldName
fnm []

    bd :: FieldName -> m Body
bd FieldName
fnm = m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (m Exp -> m Body) -> m Exp -> m Body
forall a b. (a -> b) -> a -> b
$ String -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ FieldName -> Text
_FieldName FieldName
fnm



-- | For an enum type @E@, name a map from 'Text' values to
-- inhabitants of the type, for example:
--
-- > _map_FrameRate :: Map Text FrameRate
-- > _map_FrameRate = genTextMap _text_FrameRate

map_enum_nm :: APINode -> Name
map_enum_nm :: APINode -> Name
map_enum_nm  APINode
an = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"_map_"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (TypeName -> Text
_TypeName (TypeName -> Text) -> TypeName -> Text
forall a b. (a -> b) -> a -> b
$ APINode -> TypeName
anName APINode
an)

gen_se_mp :: APINode -> Q [Dec]
gen_se_mp :: APINode -> Q [Dec]
gen_se_mp APINode
as = Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD (APINode -> Name
map_enum_nm APINode
as)
                          [t| Map.Map T.Text $TypeQ
tc |]
                          [e| genTextMap $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ APINode -> Name
text_enum_nm APINode
as) |]
  where
    tc :: TypeQ
tc  = Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ APINode -> Name
rep_type_nm APINode
as

genTextMap :: (Ord a,Bounded a,Enum a) => (a->T.Text) -> Map.Map T.Text a
genTextMap :: forall a. (Ord a, Bounded a, Enum a) => (a -> Text) -> Map Text a
genTextMap a -> Text
f = [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (a -> Text
f a
x,a
x) | a
x<-[a
forall a. Bounded a => a
minBound..a
forall a. Bounded a => a
maxBound] ]