{-# 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 Name n <- String -> Q Name forall (m :: * -> *). Quote m => String -> m Name newName String s (Q Pat, Q Exp) -> Q (Q Pat, Q Exp) forall a. a -> Q a forall (m :: * -> *) a. Monad m => a -> m a return (Name -> Q Pat forall (m :: * -> *). Quote m => Name -> m Pat varP Name n, Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp varE Name 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 (Q Pat nP, Q Exp nE) <- String -> Q (Q Pat, Q Exp) newNamePE String "n" let defaultShowClause :: Q Clause 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 :: Q Dec 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 Dec 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 -> 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 -> Q Exp -> Q Exp -> Q Exp -> [Q Dec] 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" Q Type -> Q Pat -> Q Exp -> Q Exp -> Q Dec mkBinaryInstance (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 (Name -> Q Type) -> Name -> Q Type forall a b. (a -> b) -> a -> b $ String -> Name mkName String "Le") (Name -> Q Type forall (m :: * -> *). Quote m => Name -> m Type conT Name typeName)) (Name -> [Q Pat] -> Q Pat forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat conP (String -> Name mkName String "Le") [Name -> [Q Pat] -> Q Pat forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat conP Name typeName [Q Pat n3P]]) [| $Q Exp putLe $Q Exp n3E |] [| $(Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp conE (Name -> Q Exp) -> Name -> Q Exp forall a b. (a -> b) -> a -> b $ String -> Name mkName String "Le") <$> ($(Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp conE Name typeName) <$> $Q Exp getLe) |] , do (Q Pat n3P, Q Exp n3E) <- String -> Q (Q Pat, Q Exp) newNamePE String "n" Q Type -> Q Pat -> Q Exp -> Q Exp -> Q Dec mkBinaryInstance (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 (Name -> Q Type) -> Name -> Q Type forall a b. (a -> b) -> a -> b $ String -> Name mkName String "Be") (Name -> Q Type forall (m :: * -> *). Quote m => Name -> m Type conT Name typeName)) (Name -> [Q Pat] -> Q Pat forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat conP (String -> Name mkName String "Be") [Name -> [Q Pat] -> Q Pat forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat conP Name typeName [Q Pat n3P]]) [| $Q Exp putBe $Q Exp n3E |] [| $(Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp conE (Name -> Q Exp) -> Name -> Q Exp forall a b. (a -> b) -> a -> b $ String -> Name mkName String "Be") <$> ($(Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp conE Name typeName) <$> $Q Exp getBe) |] ] let binaryInstances :: [Q Dec] binaryInstances = case BaseWord baseType of BaseWord BaseWord8 -> [ do (Q Pat n3P, Q Exp n3E) <- String -> Q (Q Pat, Q Exp) newNamePE String "n" Q Type -> Q Pat -> Q Exp -> Q Exp -> Q Dec mkBinaryInstance (Name -> Q Type forall (m :: * -> *). Quote m => Name -> m Type conT Name typeName) (Name -> [Q Pat] -> Q Pat forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat conP Name typeName [Q Pat n3P]) [| putWord8 $Q Exp n3E |] [| $(Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp conE Name 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, Integer, c) -> [m Dec] 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] 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, b, String) -> Q () 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 ((String, Integer, String) -> Q ()) -> [(String, Integer, String)] -> Q () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (Q () -> Q () addModFinalizer (Q () -> Q ()) -> ((String, Integer, String) -> Q ()) -> (String, Integer, String) -> Q () forall b c a. (b -> c) -> (a -> b) -> a -> c . (String, Integer, String) -> Q () forall {b}. (String, b, String) -> Q () mkPatternDocs) [(String, Integer, String)] enums #endif [Q Dec] -> Q [Dec] forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) forall (m :: * -> *) a. Monad m => [m a] -> m [a] sequence ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec] forall a b. (a -> b) -> a -> b $ Q Dec newTypeDef Q Dec -> [Q Dec] -> [Q Dec] forall a. a -> [a] -> [a] : Q Dec showInstance Q Dec -> [Q Dec] -> [Q Dec] forall a. a -> [a] -> [a] : [Q Dec] patterns [Q Dec] -> [Q Dec] -> [Q Dec] forall a. [a] -> [a] -> [a] ++ [Q Dec] binaryInstances