{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Parse (
Module (..)
, DocTest (..)
, Interaction
, Expression
, ExpectedResult
, ExpectedLine (..)
, LineChunk (..)
, getDocTests
, parseInteractions
, parseProperties
, mkLineChunks
) where
import Data.Char (isSpace)
import Data.List
import Data.Maybe
import Data.String
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Extract
import Location
data DocTest = Example Expression ExpectedResult | Property Expression
deriving (Eq, Show)
data LineChunk = LineChunk String | WildCardChunk
deriving (Show, Eq)
instance IsString LineChunk where
fromString = LineChunk
data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine
deriving (Show, Eq)
instance IsString ExpectedLine where
fromString = ExpectedLine . return . LineChunk
type Expression = String
type ExpectedResult = [ExpectedLine]
type Interaction = (Expression, ExpectedResult)
getDocTests :: [String] -> IO [Module [Located DocTest]]
getDocTests args = parseModules <$> extract args
parseModules :: [Module (Located String)] -> [Module [Located DocTest]]
parseModules = filter (not . isEmpty) . map parseModule
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
| ":{" : _ <- words (drop 3 (dropWhile isSpace (unLoc prompt))),
(ys,zs) <- break isBlankLine rest ->
toInteraction prompt ys : go zs
| otherwise ->
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 cleanedE)
, map mkExpectedLine result_
)
where
(prefix, e) = span isSpace x
(ePrompt, eRest) = splitAt 3 e
unindent pre = map (tryStripPrefix pre . unLoc)
cleanBody line = fromMaybe (unLoc line)
(stripPrefix ePrompt (dropWhile isSpace (unLoc line)))
(cleanedE, result_)
| (body , endLine : rest) <- break
( (==) [":}"] . take 1 . words . cleanBody)
xs
= (unlines (eRest : map cleanBody body ++
[dropWhile isSpace (cleanBody endLine)]),
unindent (takeWhile isSpace (unLoc endLine)) rest)
| otherwise = (eRest, unindent prefix xs)
tryStripPrefix :: String -> String -> String
tryStripPrefix prefix ys = fromMaybe ys $ stripPrefix prefix ys
mkExpectedLine :: String -> ExpectedLine
mkExpectedLine x = case x of
"<BLANKLINE>" -> ""
"..." -> WildCardLine
_ -> ExpectedLine $ mkLineChunks x
mkLineChunks :: String -> [LineChunk]
mkLineChunks = finish . foldr go (0, [], [])
where
mkChunk :: String -> [LineChunk]
mkChunk "" = []
mkChunk x = [LineChunk x]
go :: Char -> (Int, String, [LineChunk]) -> (Int, String, [LineChunk])
go '.' (count, acc, res) = if count == 2
then (0, "", WildCardChunk : mkChunk acc ++ res)
else (count + 1, acc, res)
go c (count, acc, res) = if count > 0
then (0, c : replicate count '.' ++ acc, res)
else (0, c : acc, res)
finish (count, acc, res) = mkChunk (replicate count '.' ++ acc) ++ res
strip :: String -> String
strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse