{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Parse (
  Module (..)
, DocTest (..)
, Expression
, ExpectedResult
, ExpectedLine (..)
, LineChunk (..)
, extractDocTests
, parseModules

#ifdef TEST
, parseInteractions
, parseProperties
, mkLineChunks
#endif
) where

import           Imports

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)

-- |
-- Extract 'DocTest's from all given modules and all modules included by the
-- given modules.
--
-- @
-- extractDocTests = fmap `parseModules` . `extract`
-- @
extractDocTests  :: [String] -> IO [Module [Located DocTest]]  -- ^ Extracted 'DocTest's
extractDocTests :: [String] -> IO [Module [Located DocTest]]
extractDocTests = 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

-- | Convert documentation to `Example`s.
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]
parseComment :: Located String -> [Located DocTest]
parseComment 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)

-- | Extract all properties from given Haddock comment.
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

-- | Extract all interactions from given Haddock comment.
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
      [] -> []

-- | Create an `Interaction`, strip superfluous whitespace as appropriate.
--
-- also merge lines between :{ and :}, preserving whitespace inside
-- the block (since this is useful for avoiding {;}).
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)  -- we do not care about leading and trailing
                        -- whitespace in expressions, so drop them
  , forall a b. (a -> b) -> [a] -> [b]
map String -> ExpectedLine
mkExpectedLine [String]
result_
  )
  where
    -- 1. drop trailing whitespace from the prompt, remember the prefix
    (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

    -- 2. drop, if possible, the exact same sequence of whitespace
    -- characters from each result line
    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


-- | Remove leading and trailing whitespace.
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