{-# LANGUAGE TemplateHaskellQuotes #-}
module Data.Array.Strided.Arith.Internal.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 | IBinop | FBinop | Unop | FUnop | Redop
  deriving (Int -> OpKind -> ShowS
[OpKind] -> ShowS
OpKind -> String
(Int -> OpKind -> ShowS)
-> (OpKind -> String) -> ([OpKind] -> ShowS) -> Show OpKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpKind -> ShowS
showsPrec :: Int -> OpKind -> ShowS
$cshow :: OpKind -> String
show :: OpKind -> String
$cshowList :: [OpKind] -> ShowS
showList :: [OpKind] -> ShowS
Show, OpKind -> OpKind -> Bool
(OpKind -> OpKind -> Bool)
-> (OpKind -> OpKind -> Bool) -> Eq OpKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpKind -> OpKind -> Bool
== :: OpKind -> OpKind -> Bool
$c/= :: OpKind -> OpKind -> Bool
/= :: OpKind -> OpKind -> Bool
Eq)

readArithLists :: OpKind
               -> (String -> Int -> String -> Q a)
               -> ([a] -> Q r)
               -> Q r
readArithLists :: forall a r.
OpKind -> (String -> Int -> String -> Q a) -> ([a] -> Q r) -> Q r
readArithLists OpKind
targetkind String -> Int -> String -> Q a
fop [a] -> Q r
fcombine = do
  String -> Q ()
addDependentFile String
"cbits/arith_lists.h"
  [String]
lns <- IO [String] -> Q [String]
forall a. IO a -> Q a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Q [String]) -> IO [String] -> Q [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
"cbits/arith_lists.h"

  [Maybe a]
mvals <- [String] -> (String -> Q (Maybe a)) -> Q [Maybe a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
lns ((String -> Q (Maybe a)) -> Q [Maybe a])
-> (String -> Q (Maybe a)) -> Q [Maybe a]
forall a b. (a -> b) -> a -> b
$ \String
line -> do
    if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
line)
      then Maybe a -> Q (Maybe a)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
      else do let (OpKind
kind, String
name, Int
num, String
aux) = String -> (OpKind, String, Int, String)
forall {c}. Read c => String -> (OpKind, String, c, String)
parseLine String
line
              if OpKind
kind OpKind -> OpKind -> Bool
forall a. Eq a => a -> a -> Bool
== OpKind
targetkind
                then a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Q a -> Q (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Int -> String -> Q a
fop String
name Int
num String
aux
                else Maybe a -> Q (Maybe a)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

  [a] -> Q r
fcombine ([Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes [Maybe a]
mvals)
  where
    parseLine :: String -> (OpKind, String, c, String)
parseLine String
s0
      | (String
"LIST_", String
s1) <- Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
5 String
s0
      , (String
kindstr, Char
'(' : String
s2) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(') String
s1
      , (String
f1, Char
',' : String
s3) <- String -> (String, String)
parseField String
s2
      , (String
f2, Char
',' : String
s4) <- String -> (String, String)
parseField String
s3
      , (String
f3, Char
')' : String
_) <- String -> (String, String)
parseField String
s4
      , Just OpKind
kind <- String -> Maybe OpKind
parseKind String
kindstr
      , let name :: String
name = String
f1
      , Just c
num <- String -> Maybe c
forall a. Read a => String -> Maybe a
readMaybe String
f2
      , let aux :: String
aux = String
f3
      = (OpKind
kind, String
name, c
num, String
aux)
      | Bool
otherwise
      = String -> (OpKind, String, c, String)
forall a. HasCallStack => String -> a
error (String -> (OpKind, String, c, String))
-> String -> (OpKind, String, c, String)
forall a b. (a -> b) -> a -> b
$ String
"readArithLists: unrecognised line in cbits/arith_lists.h: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s0

    parseField :: String -> (String, String)
parseField String
s = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
",)") ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
s)

    parseKind :: String -> Maybe OpKind
parseKind String
"BINOP" = OpKind -> Maybe OpKind
forall a. a -> Maybe a
Just OpKind
Binop
    parseKind String
"IBINOP" = OpKind -> Maybe OpKind
forall a. a -> Maybe a
Just OpKind
IBinop
    parseKind String
"FBINOP" = OpKind -> Maybe OpKind
forall a. a -> Maybe a
Just OpKind
FBinop
    parseKind String
"UNOP" = OpKind -> Maybe OpKind
forall a. a -> Maybe a
Just OpKind
Unop
    parseKind String
"FUNOP" = OpKind -> Maybe OpKind
forall a. a -> Maybe a
Just OpKind
FUnop
    parseKind String
"REDOP" = OpKind -> Maybe OpKind
forall a. a -> Maybe a
Just OpKind
Redop
    parseKind String
_ = Maybe OpKind
forall a. Maybe a
Nothing

genArithDataType :: OpKind -> String -> Q [Dec]
genArithDataType :: OpKind -> String -> Q [Dec]
genArithDataType OpKind
kind String
dtname = do
  [Con]
cons <- OpKind
-> (String -> Int -> String -> Q Con)
-> ([Con] -> Q [Con])
-> Q [Con]
forall a r.
OpKind -> (String -> Int -> String -> Q a) -> ([a] -> Q r) -> Q r
readArithLists OpKind
kind
            (\String
name Int
_num String
_ -> Con -> Q Con
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Con -> Q Con) -> Con -> Q Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC (String -> Name
mkName String
name) [])
            [Con] -> Q [Con]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD [] (String -> Name
mkName String
dtname) [] Maybe Kind
forall a. Maybe a
Nothing [Con]
cons [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Kind
ConT ''Show, Name -> Kind
ConT ''Enum, Name -> Kind
ConT ''Bounded]]]

genArithNameFun :: OpKind -> Name -> String -> (String -> String) -> Q [Dec]
genArithNameFun :: OpKind -> Name -> String -> ShowS -> Q [Dec]
genArithNameFun OpKind
kind Name
dtname String
funname ShowS
nametrans = do
  [Clause]
clauses <- OpKind
-> (String -> Int -> String -> Q Clause)
-> ([Clause] -> Q [Clause])
-> Q [Clause]
forall a r.
OpKind -> (String -> Int -> String -> Q a) -> ([a] -> Q r) -> Q r
readArithLists OpKind
kind
               (\String
name Int
_num String
_ -> Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Cxt -> [Pat] -> Pat
ConP (String -> Name
mkName String
name) [] []]
                                               (Exp -> Body
NormalB (Lit -> Exp
LitE (String -> Lit
StringL (ShowS
nametrans String
name))))
                                               []))
               [Clause] -> Q [Clause]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> Kind -> Dec
SigD (String -> Name
mkName String
funname) (Kind
ArrowT Kind -> Kind -> Kind
`AppT` Name -> Kind
ConT Name
dtname Kind -> Kind -> Kind
`AppT` Name -> Kind
ConT ''String)
         ,Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
funname) [Clause]
clauses]

genArithEnumFun :: OpKind -> Name -> String -> Q [Dec]
genArithEnumFun :: OpKind -> Name -> String -> Q [Dec]
genArithEnumFun OpKind
kind Name
dtname String
funname = do
  [Clause]
clauses <- OpKind
-> (String -> Int -> String -> Q Clause)
-> ([Clause] -> Q [Clause])
-> Q [Clause]
forall a r.
OpKind -> (String -> Int -> String -> Q a) -> ([a] -> Q r) -> Q r
readArithLists OpKind
kind
               (\String
name Int
num String
_ -> Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Cxt -> [Pat] -> Pat
ConP (String -> Name
mkName String
name) [] []]
                                              (Exp -> Body
NormalB (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num))))
                                              []))
               [Clause] -> Q [Clause]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> Kind -> Dec
SigD (String -> Name
mkName String
funname) (Kind
ArrowT Kind -> Kind -> Kind
`AppT` Name -> Kind
ConT Name
dtname Kind -> Kind -> Kind
`AppT` Name -> Kind
ConT ''CInt)
         ,Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
funname) [Clause]
clauses]