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

module Data.Elf.Constants.TH ( mkDeclarations
                             , BaseWord(..)
                             ) where

import Control.Monad
import Language.Haskell.TH
#if MIN_VERSION_template_haskell(2,18,0)
import Language.Haskell.TH.Syntax
#endif

data BaseWord = BaseWord8 | BaseWord16 | BaseWord32 | BaseWord64

newNamePE :: String -> Q (Q Pat, Q Exp)
newNamePE :: String -> Q (Q Pat, Q Exp)
newNamePE String
s = do
    n <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
s
    return (varP n, varE n)

mkDeclarations :: BaseWord -> String -> String -> [(String, Integer, String)] -> Q [Dec]
mkDeclarations :: BaseWord
-> String -> String -> [(String, Integer, String)] -> Q [Dec]
mkDeclarations BaseWord
baseType String
typeNameString String
patternPrefixString [(String, Integer, String)]
enums = do

    let typeName :: Name
typeName = String -> Name
mkName String
typeNameString
    let patternName :: String -> Name
patternName String
s = String -> Name
mkName (String
patternPrefixString String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
    let
        baseTypeT :: Q Type
        baseTypeT :: Q Type
baseTypeT =
            case BaseWord
baseType of
                BaseWord
BaseWord8  -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Word8"
                BaseWord
BaseWord16 -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Word16"
                BaseWord
BaseWord32 -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Word32"
                BaseWord
BaseWord64 -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Word64"

    let
        newTypeDef :: Q Dec
newTypeDef =
            Q Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> Q Con
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD
                ([Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
                Name
typeName
                []
                Maybe Type
forall a. Maybe a
Nothing
                (Name -> [Q BangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC Name
typeName [ Q Bang -> Q Type -> Q BangType
forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType (Q SourceUnpackedness -> Q SourceStrictness -> Q Bang
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang Q SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness Q SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness) Q Type
baseTypeT ])
                [ Maybe DerivStrategy -> [Q Type] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [ Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Eq")
                                      , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Ord")
                                      , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Enum")
                                      , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Num")
                                      , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Real")
                                      , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Integral")
                                      , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Bits")
                                      , Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"FiniteBits")
                                      ]
                ]

    let
        mkShowClause :: (t, Integer, c) -> m Clause
mkShowClause (t
s, Integer
n, c
_) =
            [m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                [ Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
typeName [Lit -> m Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Lit -> m Pat) -> Lit -> m Pat
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
n] ]
                (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| patternPrefixString ++ s |])
                []

    let
        showClauses :: [Q Clause]
        showClauses :: [Q Clause]
showClauses = ((String, Integer, String) -> Q Clause)
-> [(String, Integer, String)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (String, Integer, String) -> Q Clause
forall {m :: * -> *} {t} {c}.
(Quote m, Lift t) =>
(t, Integer, c) -> m Clause
mkShowClause [(String, Integer, String)]
enums

    (nP, nE) <- String -> Q (Q Pat, Q Exp)
newNamePE String
"n"
    let
        defaultShowClause =
            [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                [ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
typeName [Q Pat
nP] ]
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| typeNameString ++ " " ++ show $(Q Exp
nE) |])
                []

    let showInstanceFunctions = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName String
"show") ([Q Clause]
showClauses [Q Clause] -> [Q Clause] -> [Q Clause]
forall a. [a] -> [a] -> [a]
++ [ Q Clause
defaultShowClause ])

    let showInstance = Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Show")) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
typeName)) [ Q Dec
showInstanceFunctions ]

    let
        mkBinaryInstance :: Q Type -> Q Pat -> Q Exp -> Q Exp -> Q Dec
        mkBinaryInstance Q Type
typeT Q Pat
putP Q Exp
putE Q Exp
getE =
            Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
                ([Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
                (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Binary")) Q Type
typeT)
                [ Q Dec
binaryInstanceGet, Q Dec
binaryInstancePut ]
            where
                binaryInstancePut :: Q Dec
binaryInstancePut =
                    Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
                        (String -> Name
mkName String
"put")
                        [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                            [Q Pat
putP]
                            (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
putE)
                            []
                        ]
                binaryInstanceGet :: Q Dec
binaryInstanceGet =
                    Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
                        (String -> Name
mkName String
"get")
                        [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                            []
                            (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
getE)
                            []
                        ]

    let
        binaryInstancesXe Q Exp
putLe Q Exp
getLe Q Exp
putBe Q Exp
getBe =
            [ do
                (n3P, n3E) <- String -> Q (Q Pat, Q Exp)
newNamePE String
"n"
                mkBinaryInstance
                    (appT (conT $ mkName "Le") (conT typeName))
                    (conP (mkName "Le") [conP typeName [n3P]])
                    [| $putLe $n3E |]
                    [| $(conE $ mkName "Le") <$> ($(conE typeName) <$> $getLe) |]
            , do
                (n3P, n3E) <- String -> Q (Q Pat, Q Exp)
newNamePE String
"n"
                mkBinaryInstance
                    (appT (conT $ mkName "Be") (conT typeName))
                    (conP (mkName "Be") [conP typeName [n3P]])
                    [| $putBe $n3E |]
                    [| $(conE $ mkName "Be") <$> ($(conE typeName) <$> $getBe) |]
            ]

    let
        binaryInstances =
            case BaseWord
baseType of
                BaseWord
BaseWord8 ->
                    [ do
                        (n3P, n3E) <- String -> Q (Q Pat, Q Exp)
newNamePE String
"n"
                        mkBinaryInstance
                            (conT typeName)
                            (conP typeName [n3P])
                            [| putWord8 $n3E |]
                            [| $(conE typeName) <$> getWord8 |]
                    ]
                BaseWord
BaseWord16 -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> [Q Dec]
binaryInstancesXe [| putWord16le |] [| getWord16le |] [| putWord16be |] [| getWord16be |]
                BaseWord
BaseWord32 -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> [Q Dec]
binaryInstancesXe [| putWord32le |] [| getWord32le |] [| putWord32be |] [| getWord32be |]
                BaseWord
BaseWord64 -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> [Q Dec]
binaryInstancesXe [| putWord64le |] [| getWord64le |] [| putWord64be |] [| getWord64be |]

    let
        mkPatterns (String
s, Integer
n, c
_) =
            [ Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
patSynSigD
                (String -> Name
patternName String
s)
                (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
typeName)
            , Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
forall (m :: * -> *).
Quote m =>
Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD
                (String -> Name
patternName String
s)
                ([Name] -> m PatSynArgs
forall (m :: * -> *). Quote m => [Name] -> m PatSynArgs
prefixPatSyn [])
                m PatSynDir
forall (m :: * -> *). Quote m => m PatSynDir
implBidir
                (Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
typeName [Lit -> m Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Lit -> m Pat) -> Lit -> m Pat
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
n])
            ]

    let patterns = [[Q Dec]] -> [Q Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (((String, Integer, String) -> [Q Dec])
-> [(String, Integer, String)] -> [[Q Dec]]
forall a b. (a -> b) -> [a] -> [b]
map (String, Integer, String) -> [Q Dec]
forall {m :: * -> *} {c}.
Quote m =>
(String, Integer, c) -> [m Dec]
mkPatterns [(String, Integer, String)]
enums)

#if MIN_VERSION_template_haskell(2,18,0)
    let mkPatternDocs (String
s, b
_, String
doc) = DocLoc -> String -> Q ()
putDoc (Name -> DocLoc
DeclDoc (Name -> DocLoc) -> Name -> DocLoc
forall a b. (a -> b) -> a -> b
$ String -> Name
patternName String
s) String
doc

    mapM_ (addModFinalizer . mkPatternDocs) enums
#endif

    sequence $ newTypeDef : showInstance : patterns ++ binaryInstances