1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
{-# LANGUAGE TemplateHaskellQuotes #-}
module Data.Array.Nested.Internal.Arith.Lists.TH where
import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe
import Foreign.C.Types
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Text.Read
data OpKind = Binop | FBinop | Unop | FUnop | Redop
deriving (Show, Eq)
readArithLists :: OpKind
-> (String -> Int -> String -> Q a)
-> ([a] -> Q r)
-> Q r
readArithLists targetkind fop fcombine = do
addDependentFile "cbits/arith_lists.h"
lns <- liftIO $ lines <$> readFile "cbits/arith_lists.h"
mvals <- forM lns $ \line -> do
if null (dropWhile (== ' ') line)
then return Nothing
else do let (kind, name, num, aux) = parseLine line
if kind == targetkind
then Just <$> fop name num aux
else return Nothing
fcombine (catMaybes mvals)
where
parseLine s0
| ("LIST_", s1) <- splitAt 5 s0
, (kindstr, '(' : s2) <- break (== '(') s1
, (f1, ',' : s3) <- parseField s2
, (f2, ',' : s4) <- parseField s3
, (f3, ')' : _) <- parseField s4
, Just kind <- parseKind kindstr
, let name = f1
, Just num <- readMaybe f2
, let aux = f3
= (kind, name, num, aux)
| otherwise
= error $ "readArithLists: unrecognised line in cbits/arith_lists.h: " ++ show s0
parseField s = break (`elem` ",)") (dropWhile (== ' ') s)
parseKind "BINOP" = Just Binop
parseKind "FBINOP" = Just FBinop
parseKind "UNOP" = Just Unop
parseKind "FUNOP" = Just FUnop
parseKind "REDOP" = Just Redop
parseKind _ = Nothing
genArithDataType :: OpKind -> String -> Q [Dec]
genArithDataType kind dtname = do
cons <- readArithLists kind
(\name _num _ -> return $ NormalC (mkName name) [])
return
return [DataD [] (mkName dtname) [] Nothing cons [DerivClause Nothing [ConT ''Show, ConT ''Enum, ConT ''Bounded]]]
genArithNameFun :: OpKind -> Name -> String -> (String -> String) -> Q [Dec]
genArithNameFun kind dtname funname nametrans = do
clauses <- readArithLists kind
(\name _num _ -> return (Clause [ConP (mkName name) [] []]
(NormalB (LitE (StringL (nametrans name))))
[]))
return
return [SigD (mkName funname) (ArrowT `AppT` ConT dtname `AppT` ConT ''String)
,FunD (mkName funname) clauses]
genArithEnumFun :: OpKind -> Name -> String -> Q [Dec]
genArithEnumFun kind dtname funname = do
clauses <- readArithLists kind
(\name num _ -> return (Clause [ConP (mkName name) [] []]
(NormalB (LitE (IntegerL (fromIntegral num))))
[]))
return
return [SigD (mkName funname) (ArrowT `AppT` ConT dtname `AppT` ConT ''CInt)
,FunD (mkName funname) clauses]
|
