{-# 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)
-- location field for haskell-src-exts-1.18
#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
      -- to prevent "Ambiguous infix expression"
      , 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"