module Parse (
Module (..)
, DocTest (..)
, Interaction
, Expression
, ExpectedResult
, getDocTests
, parseInteractions
, parseProperties
) where
import Data.Char (isSpace)
import Data.List
import Data.Maybe
import Control.Applicative
import Extract
import Location
data DocTest = Example Expression ExpectedResult | Property Expression
deriving (Eq, Show)
type Expression = String
type ExpectedResult = [String]
type Interaction = (Expression, ExpectedResult)
getDocTests :: [String] -> IO [Module [Located DocTest]]
getDocTests args = do
filter (not . isEmpty) . map parseModule <$> extract args
where
isEmpty (Module _ setup tests) = null tests && isNothing setup
parseModule :: Module (Located String) -> Module [Located DocTest]
parseModule m = case parseComment <$> m of
Module name setup tests -> Module name setup_ (filter (not . null) tests)
where
setup_ = case setup of
Just [] -> Nothing
_ -> setup
parseComment :: Located String -> [Located DocTest]
parseComment c = properties ++ examples
where
examples = map (fmap $ uncurry Example) (parseInteractions c)
properties = map (fmap Property) (parseProperties c)
parseProperties :: Located String -> [Located Expression]
parseProperties (Located loc input) = go $ zipWith Located (enumerate loc) (lines input)
where
isPrompt :: Located String -> Bool
isPrompt = isPrefixOf "prop>" . dropWhile isSpace . unLoc
go xs = case dropWhile (not . isPrompt) xs of
prop:rest -> stripPrompt `fmap` prop : go rest
[] -> []
stripPrompt = strip . drop 5 . dropWhile isSpace
parseInteractions :: Located String -> [Located Interaction]
parseInteractions (Located loc input) = go $ zipWith Located (enumerate loc) (lines input)
where
isPrompt :: Located String -> Bool
isPrompt = isPrefixOf ">>>" . dropWhile isSpace . unLoc
isBlankLine :: Located String -> Bool
isBlankLine = null . dropWhile isSpace . unLoc
isEndOfInteraction :: Located String -> Bool
isEndOfInteraction x = isPrompt x || isBlankLine x
go :: [Located String] -> [Located Interaction]
go xs = case dropWhile (not . isPrompt) xs of
prompt:rest ->
let
(ys,zs) = break isEndOfInteraction rest
in
toInteraction prompt ys : go zs
[] -> []
toInteraction :: Located String -> [Located String] -> Located Interaction
toInteraction (Located loc x) xs = Located loc $
(
(strip $ drop 3 e)
, result_
)
where
(prefix, e) = span isSpace x
result_ = map (substituteBlankLine . tryStripPrefix prefix . unLoc) xs
where
tryStripPrefix pre ys = fromMaybe ys $ stripPrefix pre ys
substituteBlankLine "<BLANKLINE>" = ""
substituteBlankLine line = line
strip :: String -> String
strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse