{-# LANGUAGE CPP #-}
module Test.Framework.TH.Prime.Parser (
unitPropTests
, symbol, string
) where
import Control.Applicative
import Data.List
import Language.Haskell.Exts.Extension
import Language.Haskell.Exts.Parser
#if MIN_VERSION_haskell_src_exts(1, 18, 0)
import Language.Haskell.Exts.SrcLoc
#endif
import Language.Haskell.Exts.Syntax hiding (VarName, Exp)
import Language.Haskell.TH hiding (Match, Extension (..))
import Language.Preprocessor.Cpphs hiding (Ident)
#if MIN_VERSION_haskell_src_exts(1, 18, 0)
#define L SrcSpanInfo
#define loc _
#else
#define L
#define loc
#endif
symbol :: String -> Exp
symbol :: String -> Exp
symbol = Name -> Exp
VarE (Name -> Exp) -> (String -> Name) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName
string :: String -> Exp
string :: String -> Exp
string = Lit -> Exp
LitE (Lit -> Exp) -> (String -> Lit) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL
unitPropTests :: ExpQ
unitPropTests :: ExpQ
unitPropTests = do
String
file <- Loc -> String
loc_filename (Loc -> String) -> Q Loc -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
(cases :: [String]
cases, props :: [String]
props) <- IO ([String], [String]) -> Q ([String], [String])
forall a. IO a -> Q a
runIO (IO ([String], [String]) -> Q ([String], [String]))
-> IO ([String], [String]) -> Q ([String], [String])
forall a b. (a -> b) -> a -> b
$ String -> IO ([String], [String])
getTests String
file
Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
TupE [[Exp] -> Exp
ListE ((String -> Exp) -> [String] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp
toCase [String]
cases), [Exp] -> Exp
ListE ((String -> Exp) -> [String] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp
toProp [String]
props)]
toCase :: String -> Exp
toCase :: String -> Exp
toCase = String -> String -> Exp
toTest "testCase"
toProp :: String -> Exp
toProp :: String -> Exp
toProp = String -> String -> Exp
toTest "testProperty"
toTest :: String -> String -> Exp
toTest :: String -> String -> Exp
toTest tag :: String
tag nm :: String
nm = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (String -> Exp
symbol String
tag ) (String -> Exp
string String
nm)) (String -> Exp
symbol String
nm)
getTests :: FilePath -> IO ([String], [String])
getTests :: String -> IO ([String], [String])
getTests file :: String
file = do
#if MIN_VERSION_haskell_src_exts(1, 18, 0)
ParseOk (Module _ _ _ _ decls :: [Decl SrcSpanInfo]
decls) <- String -> IO (ParseResult (Module SrcSpanInfo))
parseTest String
file
#else
ParseOk (Module _ _ _ _ _ _ decls) <- parseTest file
#endif
let funs :: [String]
funs = (Decl SrcSpanInfo -> String) -> [Decl SrcSpanInfo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Decl SrcSpanInfo -> String
fromFunBind ([Decl SrcSpanInfo] -> [String]) -> [Decl SrcSpanInfo] -> [String]
forall a b. (a -> b) -> a -> b
$ (Decl SrcSpanInfo -> Bool)
-> [Decl SrcSpanInfo] -> [Decl SrcSpanInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl SrcSpanInfo -> Bool
isFunBind [Decl SrcSpanInfo]
decls
pats :: [String]
pats = (Decl SrcSpanInfo -> String) -> [Decl SrcSpanInfo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Decl SrcSpanInfo -> String
fromPatBind ([Decl SrcSpanInfo] -> [String]) -> [Decl SrcSpanInfo] -> [String]
forall a b. (a -> b) -> a -> b
$ (Decl SrcSpanInfo -> Bool)
-> [Decl SrcSpanInfo] -> [Decl SrcSpanInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl SrcSpanInfo -> Bool
isPatBind [Decl SrcSpanInfo]
decls
names :: [String]
names = [String]
funs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pats
([String], [String]) -> IO ([String], [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isCase [String]
names, (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isProp [String]
names)
where
isProp :: String -> Bool
isProp = ("prop_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
isCase :: String -> Bool
isCase = ("case_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
parseTest :: FilePath -> IO (ParseResult (Module L))
parseTest :: String -> IO (ParseResult (Module SrcSpanInfo))
parseTest file :: String
file = do
String
raw <- String -> IO String
readFile String
file
ParseMode -> String -> ParseResult (Module SrcSpanInfo)
parseModuleWithMode (String -> ParseMode
opt String
raw) (String -> ParseResult (Module SrcSpanInfo))
-> ([(Posn, String)] -> String)
-> [(Posn, String)]
-> ParseResult (Module SrcSpanInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Posn, String)] -> String
forall a. [(a, String)] -> String
pack ([(Posn, String)] -> ParseResult (Module SrcSpanInfo))
-> IO [(Posn, String)] -> IO (ParseResult (Module SrcSpanInfo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [(Posn, String)]
go String
raw
where
pack :: [(a, String)] -> String
pack = [String] -> String
unlines ([String] -> String)
-> ([(a, String)] -> [String]) -> [(a, String)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> [String])
-> ([(a, String)] -> [String]) -> [(a, String)] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, String) -> String) -> [(a, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (a, String) -> String
forall a b. (a, b) -> b
snd
go :: String -> IO [(Posn, String)]
go = String
-> [(String, String)]
-> [String]
-> BoolOptions
-> String
-> IO [(Posn, String)]
cppIfdef "dummy" [] [] BoolOptions
defaultBoolOptions
exts :: String -> [Extension]
exts raw :: String
raw =
case String -> ParseResult [ModulePragma SrcSpanInfo]
getTopPragmas String
raw of
ParseOk pragmas :: [ModulePragma SrcSpanInfo]
pragmas ->
[ Name SrcSpanInfo -> Extension
forall l. Name l -> Extension
toExtention Name SrcSpanInfo
name
| LanguagePragma _ names :: [Name SrcSpanInfo]
names <- [ModulePragma SrcSpanInfo]
pragmas, Name SrcSpanInfo
name <- [Name SrcSpanInfo]
names]
ParseFailed _ _ ->
[]
where
#if MIN_VERSION_haskell_src_exts(1, 14, 0)
toExtention :: Name l -> Extension
toExtention = String -> Extension
parseExtension (String -> Extension) -> (Name l -> String) -> Name l -> Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name l -> String
forall l. Name l -> String
toStr
#else
toExtention = read . toStr
#endif
toStr :: Name l -> String
toStr (Ident loc str) = str
toStr (Symbol loc str) = str
opt :: String -> ParseMode
opt raw :: String
raw = ParseMode
defaultParseMode {
#if MIN_VERSION_haskell_src_exts(1, 14, 0)
extensions :: [Extension]
extensions = [Extension] -> [Extension]
forall a. Eq a => [a] -> [a]
nub ([Extension] -> [Extension]) -> [Extension] -> [Extension]
forall a b. (a -> b) -> a -> b
$ KnownExtension -> Extension
EnableExtension KnownExtension
TemplateHaskell Extension -> [Extension] -> [Extension]
forall a. a -> [a] -> [a]
: String -> [Extension]
exts String
raw
#else
extensions = nub $ TemplateHaskell : exts raw
#endif
, fixities :: Maybe [Fixity]
fixities = Maybe [Fixity]
forall a. Maybe a
Nothing
}
isFunBind :: Decl L -> Bool
isFunBind :: Decl SrcSpanInfo -> Bool
isFunBind (FunBind loc _) = True
isFunBind _ = Bool
False
isPatBind :: Decl L -> Bool
isPatBind :: Decl SrcSpanInfo -> Bool
isPatBind PatBind{} = Bool
True
isPatBind _ = Bool
False
fromPatBind :: Decl L -> String
#if MIN_VERSION_haskell_src_exts(1, 16, 0)
fromPatBind :: Decl SrcSpanInfo -> String
fromPatBind (PatBind _ (PVar loc (Ident loc name)) _ _) = name
fromPatBind (PatBind _ (PVar loc (Symbol loc name)) _ _) = name
#else
fromPatBind (PatBind _ (PVar (Ident name)) _ _ _) = name
fromPatBind (PatBind _ (PVar (Symbol name)) _ _ _) = name
#endif
fromPatBind _ = String -> String
forall a. HasCallStack => String -> a
error "fromPatBind"
fromFunBind :: Decl L -> String
#if MIN_VERSION_haskell_src_exts(1, 18, 0)
fromFunBind :: Decl SrcSpanInfo -> String
fromFunBind (FunBind _floc :: SrcSpanInfo
_floc (Match _ (Ident _iloc :: SrcSpanInfo
_iloc name :: String
name) _ _ _:_)) = String
name
fromFunBind (FunBind _floc :: SrcSpanInfo
_floc (Match _ (Symbol _sloc :: SrcSpanInfo
_sloc name :: String
name) _ _ _:_)) = String
name
#else
fromFunBind (FunBind (Match _ (Ident name) _ _ _ _:_)) = name
fromFunBind (FunBind (Match _ (Symbol name) _ _ _ _:_)) = name
#endif
fromFunBind _ = String -> String
forall a. HasCallStack => String -> a
error "fromFunBind"