module Data.Packed.Static.Syntax(
mat,
matU,
vec,
vecU,
MatView,
viewMat,
VecView,
viewVec,
) where
import Data.Complex
import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Types.Data.Num.Decimal.Literals.TH
import Data.Packed.Static.Imports
import Data.Packed.Static.Shapes
import Data.Packed.Static.Vector
import Data.Packed.Static.Matrix
import Text.Parsec
import Text.Parsec.Language
import Text.Parsec.String(Parser)
import qualified Text.Parsec.Token as T
import Foreign.Storable
import qualified Language.Haskell.Meta.Parse as MP
data MatView n t = n :>< [[t]]
viewMat :: Element t => Matrix (m, n) t -> MatView (m, n) t
viewMat m = shapeOf m :>< toLists m
mat :: QuasiQuoter
mat = QuasiQuoter parseMatExp parseMatPat
matU :: QuasiQuoter
matU = QuasiQuoter parseMatUExp (error "No pattern quasiquoter for matU. Use mat instead")
parseMat p s = do
xs <- parsecToQ (sepBy (sepBy p comma) semi) s
let rows = length xs
cols = length $ head xs
when (not $ all ((==cols) . length) xs) $ fail "Inconsistent row lengths in [$mat|...|]"
return (xs,rows,cols)
parseMatExp s = do
(xs,rows,cols) <- parseMat expr s
[| ( $(decLiteralV $ fromIntegral rows) >< $(decLiteralV $ fromIntegral cols) )
$(return $ ListE (concat xs)) |]
parseMatUExp s = do
(xs,rows,cols) <- parseMat expr s
[| fromListsU $(return $ ListE (map ListE xs)) |]
parseMatPat s = do
(xs,rows,cols) <- parseMat identifier s
conP '(:><) [ sigP wildP (tupleT 2 `appT` (decLiteralT $ fromIntegral rows) `appT` (decLiteralT $ fromIntegral cols))
, listP (map (listP . map (varP . mkName)) xs) ]
data VecView n t = n :|> [t]
viewVec :: (Storable t) => Vector n t -> VecView n t
viewVec v = shapeOf v :|> toList v
vec :: QuasiQuoter
vec = QuasiQuoter parseVecExp parseVecPat
vecU :: QuasiQuoter
vecU = QuasiQuoter parseVecUExp (error "No pattern quasiquoter for vecU. Use the vec quasiquoter instead")
parseVec p s = parsecToQ (sepBy p comma) s
parseVecPat s = do
xs <- parseVec identifier s
conP '(:|>) [ sigP wildP (decLiteralT $ fromIntegral $ length xs)
, return $ ListP (map (VarP . mkName) xs) ]
parseVecUExp s = [| fromListU $(ListE `liftM` parseVec expr s) |]
parseVecExp s = do
xs <- parseVec expr s
[| unsafeReshape (fromListU $(return $ ListE xs)) `atShape` $(decLiteralV (fromIntegral $ length xs)) |]
expr = do
s <- outerCode
case MP.parseExp s of
Left err -> fail err
Right exp -> return exp
infixr >>+
p1 >>+ p2 = do
x1 <- p1
x2 <- p2
return (x1 ++ x2)
p >/> q = do
p' <- p
notFollowedBy q
return p'
codeChar = noneOf "{}()[]-,;\"\'" <|> (try (char '-' >/> char '-'))
innerCodeChar = codeChar <|> char ','
outerCode = fmap concat $ many (fmap return codeChar <|> codeChoices)
innerCode = fmap concat $ many (fmap return innerCodeChar <|> codeChoices)
codeChoices = (nestedCommentCode <|> singleLineCommentCode <|>
stringLit <|> charLit <|> bracesCode <|> parensCode <|> bracketsCode)
bracesCode = string "{" >>+ innerCode >>+ string "}"
parensCode = string "(" >>+ innerCode >>+ string ")"
bracketsCode = string "[" >>+ innerCode >>+ string "]"
nestedCommentCode = try (string "{-") >>+ insideNestedCode >>+ string "-}"
insideNestedCode = fmap concat $ many (nestedCommentCode <|> fmap return (noneOf "-") <|> try (string "-" >/> char '}'))
singleLineCommentCode = (try $ string "--") >>+ manyTill anyChar newline
stringLit = fmap show $ stringLiteral
charLit = fmap show $ charLiteral
identifier = T.identifier haskell
comma = T.comma haskell <?> "comma"
stringLiteral = T.stringLiteral haskell
charLiteral = T.charLiteral haskell
semi = T.semi haskell <?> "semicolon"
parsecToQ :: Parser a -> String -> Q a
parsecToQ p s = do
loc <- location
let file = loc_filename loc
(line,col) = loc_start loc
p' = do pos <- getPosition
setPosition $
(flip setSourceName) file $
(flip setSourceLine) line $
(flip setSourceColumn) col $ pos
v <- p
eof
return v
e <- case runParser p' () "" s of
Left err -> fail $ show err
Right e -> return e
return e