{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}

module System.Win32.Error.TH
  ( genErrCode
  , gentoDWORD
  , genfromDWORD
  ) where

import Language.Haskell.TH
import System.Win32 (DWORD)

import System.Win32.Error.Mapping

errCode :: Name
errCode :: Name
errCode = String -> Name
mkName String
"ErrCode"

errOther :: Name
errOther :: Name
errOther = String -> Name
mkName String
"Other"

-- |Given something like [(undefined, "Success")], the following will be produced:
--     data ErrCode
--         = Success
--         | Other !DWORD
--         deriving (Eq, Show)
genErrCode :: Q [Dec]

#if MIN_VERSION_template_haskell(2,12,0)
genErrCode :: Q [Dec]
genErrCode = [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
errCode []  Maybe Kind
forall a. Maybe a
Nothing [Con]
cons [(Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing (Cxt -> DerivClause) -> Cxt -> DerivClause
forall a b. (a -> b) -> a -> b
$ (Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
ConT [''Eq, ''Show])]]
#elif MIN_VERSION_template_haskell(2,11,0)
genErrCode = return [DataD [] errCode []  Nothing cons (map ConT [''Eq, ''Show])]
#else
genErrCode = return [DataD [] errCode [] cons [''Eq, ''Show]]
#endif
  where
    con :: Name -> Con
con Name
name = Name -> [BangType] -> Con
NormalC Name
name []
#if __GLASGOW_HASKELL__ < 800
    cons = map (con . snd) mapping ++ [NormalC errOther [(IsStrict, ConT ''DWORD)]]
#else
    cons :: [Con]
cons = ((DWORD, Name) -> Con) -> [(DWORD, Name)] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Con
con (Name -> Con) -> ((DWORD, Name) -> Name) -> (DWORD, Name) -> Con
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DWORD, Name) -> Name
forall a b. (a, b) -> b
snd) [(DWORD, Name)]
mapping [Con] -> [Con] -> [Con]
forall a. [a] -> [a] -> [a]
++ [Name -> [BangType] -> Con
NormalC Name
errOther [(SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict, Name -> Kind
ConT ''DWORD)]]
#endif

-- toDWORD :: ErrCode -> DWORD
-- toDWORD (ErrorOther x) = x
-- toDWORD errorSomethingElse = #
-- toDWORD errorSomethingElse = #
-- toDWORD errorSomethingElse = #
gentoDWORD :: Q [Dec]
gentoDWORD :: Q [Dec]
gentoDWORD  = do
    Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> Kind -> Dec
SigD Name
toDWORD (Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
ArrowT (Name -> Kind
ConT Name
errCode)) (Name -> Kind
ConT ''DWORD))
           , Name -> [Clause] -> Dec
FunD Name
toDWORD ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Cxt -> [Pat] -> Pat
ConP Name
errOther [] [Name -> Pat
VarP Name
x]] (Exp -> Body
NormalB (Name -> Exp
VarE Name
x)) [] Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
: ((DWORD, Name) -> Clause) -> [(DWORD, Name)] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (DWORD, Name) -> Clause
genClause [(DWORD, Name)]
mapping
           ]
  where
    toDWORD :: Name
toDWORD = String -> Name
mkName String
"toDWORD"
    genClause :: (DWORD, Name) -> Clause
    genClause :: (DWORD, Name) -> Clause
genClause (DWORD
dw, Name
err) = [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Cxt -> [Pat] -> Pat
ConP Name
err [] []] (Exp -> Body
NormalB (Lit -> Exp
LitE (Lit -> Exp) -> (DWORD -> Lit) -> DWORD -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DWORD -> Lit
litDWORD (DWORD -> Exp) -> DWORD -> Exp
forall a b. (a -> b) -> a -> b
$ DWORD
dw)) []

-- fromDWORD :: DWORD -> ErrCode
-- fromDWORD 0 = ErrorSuccess
-- fromDWORD # = ErrorSomethingElse
-- fromDWORD # = ErrorSomethingElse
-- fromDWORD # = ErrorSomethingElse
-- fromDWORD x = ErrorOther x
genfromDWORD :: Q [Dec]
genfromDWORD :: Q [Dec]
genfromDWORD = do
    Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> Kind -> Dec
SigD Name
fromDWORD (Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
ArrowT (Name -> Kind
ConT ''DWORD)) (Name -> Kind
ConT Name
errCode))
           , Name -> [Clause] -> Dec
FunD Name
fromDWORD ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ ((DWORD, Name) -> Clause) -> [(DWORD, Name)] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (DWORD, Name) -> Clause
genClause [(DWORD, Name)]
mapping [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
x] (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
errOther) (Name -> Exp
VarE Name
x))) []]
           ]
  where
    fromDWORD :: Name
fromDWORD = String -> Name
mkName String
"fromDWORD"
    genClause :: (DWORD, Name) -> Clause
    genClause :: (DWORD, Name) -> Clause
genClause (DWORD
dw, Name
err) = [Pat] -> Body -> [Dec] -> Clause
Clause [Lit -> Pat
LitP (Lit -> Pat) -> Lit -> Pat
forall a b. (a -> b) -> a -> b
$ DWORD -> Lit
litDWORD DWORD
dw] (Exp -> Body
NormalB (Name -> Exp
ConE  Name
err)) []

litDWORD :: DWORD -> Lit
litDWORD :: DWORD -> Lit
litDWORD = Integer -> Lit
IntegerL (Integer -> Lit) -> (DWORD -> Integer) -> DWORD -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DWORD -> Integer
forall a. Integral a => a -> Integer
toInteger