{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Parse (
Module (..)
, DocTest (..)
, Expression
, ExpectedResult
, ExpectedLine (..)
, LineChunk (..)
, extractDocTests
, parseModules
#ifdef TEST
, parseInteractions
, parseProperties
, mkLineChunks
#endif
) where
import Data.Char (isSpace)
import Data.List (isPrefixOf, stripPrefix)
import Data.Maybe
import Data.String
import Extract
import Location
data DocTest = Example Expression ExpectedResult | Property Expression
deriving (DocTest -> DocTest -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DocTest -> DocTest -> Bool
$c/= :: DocTest -> DocTest -> Bool
== :: DocTest -> DocTest -> Bool
$c== :: DocTest -> DocTest -> Bool
Eq, Int -> DocTest -> ShowS
[DocTest] -> ShowS
DocTest -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DocTest] -> ShowS
$cshowList :: [DocTest] -> ShowS
show :: DocTest -> String
$cshow :: DocTest -> String
showsPrec :: Int -> DocTest -> ShowS
$cshowsPrec :: Int -> DocTest -> ShowS
Show)
data LineChunk = LineChunk String | WildCardChunk
deriving (Int -> LineChunk -> ShowS
[LineChunk] -> ShowS
LineChunk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LineChunk] -> ShowS
$cshowList :: [LineChunk] -> ShowS
show :: LineChunk -> String
$cshow :: LineChunk -> String
showsPrec :: Int -> LineChunk -> ShowS
$cshowsPrec :: Int -> LineChunk -> ShowS
Show, LineChunk -> LineChunk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LineChunk -> LineChunk -> Bool
$c/= :: LineChunk -> LineChunk -> Bool
== :: LineChunk -> LineChunk -> Bool
$c== :: LineChunk -> LineChunk -> Bool
Eq)
instance IsString LineChunk where
fromString :: String -> LineChunk
fromString = String -> LineChunk
LineChunk
data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine
deriving (Int -> ExpectedLine -> ShowS
ExpectedResult -> ShowS
ExpectedLine -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: ExpectedResult -> ShowS
$cshowList :: ExpectedResult -> ShowS
show :: ExpectedLine -> String
$cshow :: ExpectedLine -> String
showsPrec :: Int -> ExpectedLine -> ShowS
$cshowsPrec :: Int -> ExpectedLine -> ShowS
Show, ExpectedLine -> ExpectedLine -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExpectedLine -> ExpectedLine -> Bool
$c/= :: ExpectedLine -> ExpectedLine -> Bool
== :: ExpectedLine -> ExpectedLine -> Bool
$c== :: ExpectedLine -> ExpectedLine -> Bool
Eq)
instance IsString ExpectedLine where
fromString :: String -> ExpectedLine
fromString = [LineChunk] -> ExpectedLine
ExpectedLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LineChunk
LineChunk
type Expression = String
type ExpectedResult = [ExpectedLine]
type Interaction = (Expression, ExpectedResult)
extractDocTests :: [String] -> IO [Module [Located DocTest]]
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Module (Located String)] -> [Module [Located DocTest]]
parseModules forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> IO [Module (Located String)]
extract
parseModules :: [Module (Located String)] -> [Module [Located DocTest]]
parseModules :: [Module (Located String)] -> [Module [Located DocTest]]
parseModules = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Module a -> Bool
isEmpty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Module (Located String) -> Module [Located DocTest]
parseModule
where
isEmpty :: Module a -> Bool
isEmpty (Module String
_ Maybe a
setup [a]
tests) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
tests Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe a
setup
parseModule :: Module (Located String) -> Module [Located DocTest]
parseModule :: Module (Located String) -> Module [Located DocTest]
parseModule Module (Located String)
m = case Located String -> [Located DocTest]
parseComment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module (Located String)
m of
Module String
name Maybe [Located DocTest]
setup [[Located DocTest]]
tests -> forall a. String -> Maybe a -> [a] -> Module a
Module String
name Maybe [Located DocTest]
setup_ (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Located DocTest]]
tests)
where
setup_ :: Maybe [Located DocTest]
setup_ = case Maybe [Located DocTest]
setup of
Just [] -> forall a. Maybe a
Nothing
Maybe [Located DocTest]
_ -> Maybe [Located DocTest]
setup
parseComment :: Located String -> [Located DocTest]
Located String
c = [Located DocTest]
properties forall a. [a] -> [a] -> [a]
++ [Located DocTest]
examples
where
examples :: [Located DocTest]
examples = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> ExpectedResult -> DocTest
Example) (Located String -> [Located (String, ExpectedResult)]
parseInteractions Located String
c)
properties :: [Located DocTest]
properties = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> DocTest
Property) (Located String -> [Located String]
parseProperties Located String
c)
parseProperties :: Located String -> [Located Expression]
parseProperties :: Located String -> [Located String]
parseProperties (Located Location
loc String
input) = [Located String] -> [Located String]
go forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Location -> a -> Located a
Located (Location -> [Location]
enumerate Location
loc) (String -> [String]
lines String
input)
where
isPrompt :: Located String -> Bool
isPrompt :: Located String -> Bool
isPrompt = forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"prop>" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> a
unLoc
go :: [Located String] -> [Located String]
go [Located String]
xs = case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located String -> Bool
isPrompt) [Located String]
xs of
Located String
prop:[Located String]
rest -> ShowS
stripPrompt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Located String
prop forall a. a -> [a] -> [a]
: [Located String] -> [Located String]
go [Located String]
rest
[] -> []
stripPrompt :: ShowS
stripPrompt = ShowS
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
5 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
parseInteractions :: Located String -> [Located Interaction]
parseInteractions :: Located String -> [Located (String, ExpectedResult)]
parseInteractions (Located Location
loc String
input) = [Located String] -> [Located (String, ExpectedResult)]
go forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Location -> a -> Located a
Located (Location -> [Location]
enumerate Location
loc) (String -> [String]
lines String
input)
where
isPrompt :: Located String -> Bool
isPrompt :: Located String -> Bool
isPrompt = forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
">>>" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> a
unLoc
isBlankLine :: Located String -> Bool
isBlankLine :: Located String -> Bool
isBlankLine = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> a
unLoc
isEndOfInteraction :: Located String -> Bool
isEndOfInteraction :: Located String -> Bool
isEndOfInteraction Located String
x = Located String -> Bool
isPrompt Located String
x Bool -> Bool -> Bool
|| Located String -> Bool
isBlankLine Located String
x
go :: [Located String] -> [Located Interaction]
go :: [Located String] -> [Located (String, ExpectedResult)]
go [Located String]
xs = case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located String -> Bool
isPrompt) [Located String]
xs of
Located String
prompt:[Located String]
rest
| String
":{" : [String]
_ <- String -> [String]
words (forall a. Int -> [a] -> [a]
drop Int
3 (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (forall a. Located a -> a
unLoc Located String
prompt))),
([Located String]
ys,[Located String]
zs) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
break Located String -> Bool
isBlankLine [Located String]
rest ->
Located String
-> [Located String] -> Located (String, ExpectedResult)
toInteraction Located String
prompt [Located String]
ys forall a. a -> [a] -> [a]
: [Located String] -> [Located (String, ExpectedResult)]
go [Located String]
zs
| Bool
otherwise ->
let
([Located String]
ys,[Located String]
zs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Located String -> Bool
isEndOfInteraction [Located String]
rest
in
Located String
-> [Located String] -> Located (String, ExpectedResult)
toInteraction Located String
prompt [Located String]
ys forall a. a -> [a] -> [a]
: [Located String] -> [Located (String, ExpectedResult)]
go [Located String]
zs
[] -> []
toInteraction :: Located String -> [Located String] -> Located Interaction
toInteraction :: Located String
-> [Located String] -> Located (String, ExpectedResult)
toInteraction (Located Location
loc String
x) [Located String]
xs = forall a. Location -> a -> Located a
Located Location
loc forall a b. (a -> b) -> a -> b
$
(
(ShowS
strip String
cleanedE)
, forall a b. (a -> b) -> [a] -> [b]
map String -> ExpectedLine
mkExpectedLine [String]
result_
)
where
(String
prefix, String
e) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSpace String
x
(String
ePrompt, String
eRest) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
3 String
e
unindent :: String -> [Located String] -> [String]
unindent String
pre = forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
tryStripPrefix String
pre forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> a
unLoc)
cleanBody :: Located String -> String
cleanBody Located String
line = forall a. a -> Maybe a -> a
fromMaybe (forall a. Located a -> a
unLoc Located String
line)
(forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
ePrompt (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (forall a. Located a -> a
unLoc Located String
line)))
(String
cleanedE, [String]
result_)
| ([Located String]
body , Located String
endLine : [Located String]
rest) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
break
( forall a. Eq a => a -> a -> Bool
(==) [String
":}"] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located String -> String
cleanBody)
[Located String]
xs
= ([String] -> String
unlines (String
eRest forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
cleanBody [Located String]
body forall a. [a] -> [a] -> [a]
++
[forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (Located String -> String
cleanBody Located String
endLine)]),
String -> [Located String] -> [String]
unindent (forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isSpace (forall a. Located a -> a
unLoc Located String
endLine)) [Located String]
rest)
| Bool
otherwise = (String
eRest, String -> [Located String] -> [String]
unindent String
prefix [Located String]
xs)
tryStripPrefix :: String -> String -> String
tryStripPrefix :: String -> ShowS
tryStripPrefix String
prefix String
ys = forall a. a -> Maybe a -> a
fromMaybe String
ys forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix String
ys
mkExpectedLine :: String -> ExpectedLine
mkExpectedLine :: String -> ExpectedLine
mkExpectedLine String
x = case String
x of
String
"<BLANKLINE>" -> ExpectedLine
""
String
"..." -> ExpectedLine
WildCardLine
String
_ -> [LineChunk] -> ExpectedLine
ExpectedLine forall a b. (a -> b) -> a -> b
$ String -> [LineChunk]
mkLineChunks String
x
mkLineChunks :: String -> [LineChunk]
mkLineChunks :: String -> [LineChunk]
mkLineChunks = (Int, String, [LineChunk]) -> [LineChunk]
finish forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> (Int, String, [LineChunk]) -> (Int, String, [LineChunk])
go (Int
0, [], [])
where
mkChunk :: String -> [LineChunk]
mkChunk :: String -> [LineChunk]
mkChunk String
"" = []
mkChunk String
x = [String -> LineChunk
LineChunk String
x]
go :: Char -> (Int, String, [LineChunk]) -> (Int, String, [LineChunk])
go :: Char -> (Int, String, [LineChunk]) -> (Int, String, [LineChunk])
go Char
'.' (Int
count, String
acc, [LineChunk]
res) = if Int
count forall a. Eq a => a -> a -> Bool
== Int
2
then (Int
0, String
"", LineChunk
WildCardChunk forall a. a -> [a] -> [a]
: String -> [LineChunk]
mkChunk String
acc forall a. [a] -> [a] -> [a]
++ [LineChunk]
res)
else (Int
count forall a. Num a => a -> a -> a
+ Int
1, String
acc, [LineChunk]
res)
go Char
c (Int
count, String
acc, [LineChunk]
res) = if Int
count forall a. Ord a => a -> a -> Bool
> Int
0
then (Int
0, Char
c forall a. a -> [a] -> [a]
: forall a. Int -> a -> [a]
replicate Int
count Char
'.' forall a. [a] -> [a] -> [a]
++ String
acc, [LineChunk]
res)
else (Int
0, Char
c forall a. a -> [a] -> [a]
: String
acc, [LineChunk]
res)
finish :: (Int, String, [LineChunk]) -> [LineChunk]
finish (Int
count, String
acc, [LineChunk]
res) = String -> [LineChunk]
mkChunk (forall a. Int -> a -> [a]
replicate Int
count Char
'.' forall a. [a] -> [a] -> [a]
++ String
acc) forall a. [a] -> [a] -> [a]
++ [LineChunk]
res
strip :: String -> String
strip :: ShowS
strip = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse