{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
{-# LANGUAGE TemplateHaskell #-}

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

import Control.Monad
import Language.Haskell.TH

data BaseWord = BaseWord8 | BaseWord16 | BaseWord32 | BaseWord64

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

mkDeclarations :: BaseWord -> String -> String -> String -> [(String, Integer)] -> Q [Dec]
mkDeclarations :: BaseWord
-> String -> String -> String -> [(String, Integer)] -> Q [Dec]
mkDeclarations BaseWord
baseType String
typeNameString String
patternPrefixString String
defaultPatternNameString [(String, Integer)]
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 defaultPatternName :: Name
defaultPatternName = String -> Name
mkName String
defaultPatternNameString
    let
        baseTypeT :: TypeQ
baseTypeT =
            case BaseWord
baseType of
                BaseWord
BaseWord8  -> Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Word8"
                BaseWord
BaseWord16 -> Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Word16"
                BaseWord
BaseWord32 -> Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Word32"
                BaseWord
BaseWord64 -> Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Word64"

    let
        newTypeDef :: DecQ
newTypeDef =
            CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> ConQ
-> [DerivClauseQ]
-> DecQ
newtypeD
                ([TypeQ] -> CxtQ
cxt [])
                Name
typeName
                []
                Maybe Kind
forall a. Maybe a
Nothing
                (Name -> [BangTypeQ] -> ConQ
normalC Name
typeName [ BangQ -> TypeQ -> BangTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness) TypeQ
baseTypeT ])
                [ Maybe DerivStrategy -> [TypeQ] -> DerivClauseQ
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [ Name -> TypeQ
conT (String -> Name
mkName String
"Eq")
                                      , Name -> TypeQ
conT (String -> Name
mkName String
"Ord")
                                      , Name -> TypeQ
conT (String -> Name
mkName String
"Enum")
                                      , Name -> TypeQ
conT (String -> Name
mkName String
"Num")
                                      , Name -> TypeQ
conT (String -> Name
mkName String
"Real")
                                      , Name -> TypeQ
conT (String -> Name
mkName String
"Integral")
                                      , Name -> TypeQ
conT (String -> Name
mkName String
"Bits")
                                      , Name -> TypeQ
conT (String -> Name
mkName String
"FiniteBits")
                                      ]
                ]

    let
        mkShowClause :: (t, Integer) -> ClauseQ
mkShowClause (t
s, Integer
n) =
            [Q Pat] -> BodyQ -> [DecQ] -> ClauseQ
clause
                [ Name -> [Q Pat] -> Q Pat
conP Name
typeName [Lit -> Q Pat
litP (Lit -> Q Pat) -> Lit -> Q Pat
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
n] ]
                (Q Exp -> BodyQ
normalB [| patternPrefixString ++ s |])
                []

    let showClauses :: [ClauseQ]
showClauses = ((String, Integer) -> ClauseQ) -> [(String, Integer)] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (String, Integer) -> ClauseQ
forall t. Lift t => (t, Integer) -> ClauseQ
mkShowClause [(String, Integer)]
enums

    (Q Pat
nP, Q Exp
nE) <- String -> Q (Q Pat, Q Exp)
newNamePE String
"n"
    let
        defaultShowClause :: ClauseQ
defaultShowClause =
            [Q Pat] -> BodyQ -> [DecQ] -> ClauseQ
clause
                [ Name -> [Q Pat] -> Q Pat
conP Name
typeName [Q Pat
nP] ]
                (Q Exp -> BodyQ
normalB [| defaultPatternNameString ++ " " ++ show $(nE) |])
                []

    let showInstanceFunctions :: DecQ
showInstanceFunctions = Name -> [ClauseQ] -> DecQ
funD (String -> Name
mkName String
"show") ([ClauseQ]
showClauses [ClauseQ] -> [ClauseQ] -> [ClauseQ]
forall a. [a] -> [a] -> [a]
++ [ ClauseQ
defaultShowClause ])

    let showInstance :: DecQ
showInstance = CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (String -> Name
mkName String
"Show")) (Name -> TypeQ
conT Name
typeName)) [ DecQ
showInstanceFunctions ]

    let
        mkBinaryInstance :: Q Type -> Q Pat -> Q Exp -> Q Exp -> Q Dec
        mkBinaryInstance :: TypeQ -> Q Pat -> Q Exp -> Q Exp -> DecQ
mkBinaryInstance TypeQ
typeT Q Pat
putP Q Exp
putE Q Exp
getE =
            CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD
                ([TypeQ] -> CxtQ
cxt [])
                (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (String -> Name
mkName String
"Binary")) TypeQ
typeT)
                [ DecQ
binaryInstanceGet, DecQ
binaryInstancePut ]
            where
                binaryInstancePut :: DecQ
binaryInstancePut =
                    Name -> [ClauseQ] -> DecQ
funD
                        (String -> Name
mkName String
"put")
                        [ [Q Pat] -> BodyQ -> [DecQ] -> ClauseQ
clause
                            [Q Pat
putP]
                            (Q Exp -> BodyQ
normalB Q Exp
putE)
                            []
                        ]
                binaryInstanceGet :: DecQ
binaryInstanceGet =
                    Name -> [ClauseQ] -> DecQ
funD
                        (String -> Name
mkName String
"get")
                        [ [Q Pat] -> BodyQ -> [DecQ] -> ClauseQ
clause
                            []
                            (Q Exp -> BodyQ
normalB Q Exp
getE)
                            []
                        ]

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

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

    let
        mkPatterns :: (String, Integer) -> [DecQ]
mkPatterns (String
s, Integer
n) =
            [ Name -> TypeQ -> DecQ
patSynSigD
                (String -> Name
patternName String
s)
                (Name -> TypeQ
conT Name
typeName)
            , Name -> PatSynArgsQ -> PatSynDirQ -> Q Pat -> DecQ
patSynD
                (String -> Name
patternName String
s)
                ([Name] -> PatSynArgsQ
prefixPatSyn [])
                PatSynDirQ
implBidir
                (Name -> [Q Pat] -> Q Pat
conP Name
typeName [Lit -> Q Pat
litP (Lit -> Q Pat) -> Lit -> Q Pat
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
n])
            ]

    let
        defaultPatternSig :: DecQ
defaultPatternSig =
            Name -> TypeQ -> DecQ
patSynSigD
                Name
defaultPatternName
                (TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT TypeQ
baseTypeT) (Name -> TypeQ
conT Name
typeName))

    Name
localName3 <- String -> Q Name
newName String
"n"

    let
        defaultPatternDef :: DecQ
defaultPatternDef =
            Name -> PatSynArgsQ -> PatSynDirQ -> Q Pat -> DecQ
patSynD
                Name
defaultPatternName
                ([Name] -> PatSynArgsQ
prefixPatSyn [Name
localName3])
                PatSynDirQ
implBidir
                (Name -> [Q Pat] -> Q Pat
conP Name
typeName [Name -> Q Pat
varP Name
localName3])

    let patterns :: [DecQ]
patterns = [[DecQ]] -> [DecQ]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (((String, Integer) -> [DecQ]) -> [(String, Integer)] -> [[DecQ]]
forall a b. (a -> b) -> [a] -> [b]
map (String, Integer) -> [DecQ]
mkPatterns [(String, Integer)]
enums) [DecQ] -> [DecQ] -> [DecQ]
forall a. [a] -> [a] -> [a]
++ [ DecQ
defaultPatternSig, DecQ
defaultPatternDef ]

    [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([DecQ] -> Q [Dec]) -> [DecQ] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ DecQ
newTypeDef DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
: DecQ
showInstance DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
: [DecQ]
patterns [DecQ] -> [DecQ] -> [DecQ]
forall a. [a] -> [a] -> [a]
++ [DecQ]
binaryInstances