{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hedgehog.Internal.Discovery (
    PropertySource(..)
  , readProperties
  , findProperties
  , readDeclaration

  , Pos(..)
  , Position(..)
  ) where

import           Control.Exception (IOException, handle)
import           Control.Monad.IO.Class (MonadIO(..))

import qualified Data.Char as Char
import qualified Data.List as List
import           Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Ord as Ord
import           Data.Semigroup (Semigroup(..))

import           Hedgehog.Internal.Property (PropertyName(..))
import           Hedgehog.Internal.Source (LineNo(..), ColumnNo(..))

------------------------------------------------------------------------
-- Property Extraction

newtype PropertySource =
  PropertySource {
      PropertySource -> Pos String
propertySource :: Pos String
    } deriving (PropertySource -> PropertySource -> Bool
(PropertySource -> PropertySource -> Bool)
-> (PropertySource -> PropertySource -> Bool) -> Eq PropertySource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PropertySource -> PropertySource -> Bool
$c/= :: PropertySource -> PropertySource -> Bool
== :: PropertySource -> PropertySource -> Bool
$c== :: PropertySource -> PropertySource -> Bool
Eq, Eq PropertySource
Eq PropertySource =>
(PropertySource -> PropertySource -> Ordering)
-> (PropertySource -> PropertySource -> Bool)
-> (PropertySource -> PropertySource -> Bool)
-> (PropertySource -> PropertySource -> Bool)
-> (PropertySource -> PropertySource -> Bool)
-> (PropertySource -> PropertySource -> PropertySource)
-> (PropertySource -> PropertySource -> PropertySource)
-> Ord PropertySource
PropertySource -> PropertySource -> Bool
PropertySource -> PropertySource -> Ordering
PropertySource -> PropertySource -> PropertySource
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PropertySource -> PropertySource -> PropertySource
$cmin :: PropertySource -> PropertySource -> PropertySource
max :: PropertySource -> PropertySource -> PropertySource
$cmax :: PropertySource -> PropertySource -> PropertySource
>= :: PropertySource -> PropertySource -> Bool
$c>= :: PropertySource -> PropertySource -> Bool
> :: PropertySource -> PropertySource -> Bool
$c> :: PropertySource -> PropertySource -> Bool
<= :: PropertySource -> PropertySource -> Bool
$c<= :: PropertySource -> PropertySource -> Bool
< :: PropertySource -> PropertySource -> Bool
$c< :: PropertySource -> PropertySource -> Bool
compare :: PropertySource -> PropertySource -> Ordering
$ccompare :: PropertySource -> PropertySource -> Ordering
$cp1Ord :: Eq PropertySource
Ord, Int -> PropertySource -> ShowS
[PropertySource] -> ShowS
PropertySource -> String
(Int -> PropertySource -> ShowS)
-> (PropertySource -> String)
-> ([PropertySource] -> ShowS)
-> Show PropertySource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PropertySource] -> ShowS
$cshowList :: [PropertySource] -> ShowS
show :: PropertySource -> String
$cshow :: PropertySource -> String
showsPrec :: Int -> PropertySource -> ShowS
$cshowsPrec :: Int -> PropertySource -> ShowS
Show)

readProperties :: MonadIO m => String -> FilePath -> m (Map PropertyName PropertySource)
readProperties :: String -> String -> m (Map PropertyName PropertySource)
readProperties prefix :: String
prefix path :: String
path =
  String -> String -> String -> Map PropertyName PropertySource
findProperties String
prefix String
path (String -> Map PropertyName PropertySource)
-> m String -> m (Map PropertyName PropertySource)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO String
readFile String
path)

readDeclaration :: MonadIO m => FilePath -> LineNo -> m (Maybe (String, Pos String))
readDeclaration :: String -> LineNo -> m (Maybe (String, Pos String))
readDeclaration path :: String
path line :: LineNo
line = do
  Maybe String
mfile <- IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
readFileSafe String
path
  Maybe (String, Pos String) -> m (Maybe (String, Pos String))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (String, Pos String) -> m (Maybe (String, Pos String)))
-> Maybe (String, Pos String) -> m (Maybe (String, Pos String))
forall a b. (a -> b) -> a -> b
$ do
    String
file <- Maybe String
mfile
    [(String, Pos String)] -> Maybe (String, Pos String)
forall a. [a] -> Maybe a
takeHead ([(String, Pos String)] -> Maybe (String, Pos String))
-> ([(String, Pos String)] -> [(String, Pos String)])
-> [(String, Pos String)]
-> Maybe (String, Pos String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ((String, Pos String) -> (String, Pos String) -> Ordering)
-> [(String, Pos String)] -> [(String, Pos String)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (((String, Pos String) -> Down LineNo)
-> (String, Pos String) -> (String, Pos String) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
Ord.comparing (((String, Pos String) -> Down LineNo)
 -> (String, Pos String) -> (String, Pos String) -> Ordering)
-> ((String, Pos String) -> Down LineNo)
-> (String, Pos String)
-> (String, Pos String)
-> Ordering
forall a b. (a -> b) -> a -> b
$ LineNo -> Down LineNo
forall a. a -> Down a
Ord.Down (LineNo -> Down LineNo)
-> ((String, Pos String) -> LineNo)
-> (String, Pos String)
-> Down LineNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> LineNo
posLine (Position -> LineNo)
-> ((String, Pos String) -> Position)
-> (String, Pos String)
-> LineNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos String -> Position
forall a. Pos a -> Position
posPostion (Pos String -> Position)
-> ((String, Pos String) -> Pos String)
-> (String, Pos String)
-> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Pos String) -> Pos String
forall a b. (a, b) -> b
snd) ([(String, Pos String)] -> [(String, Pos String)])
-> ([(String, Pos String)] -> [(String, Pos String)])
-> [(String, Pos String)]
-> [(String, Pos String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ((String, Pos String) -> Bool)
-> [(String, Pos String)] -> [(String, Pos String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((LineNo -> LineNo -> Bool
forall a. Ord a => a -> a -> Bool
<= LineNo
line) (LineNo -> Bool)
-> ((String, Pos String) -> LineNo) -> (String, Pos String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> LineNo
posLine (Position -> LineNo)
-> ((String, Pos String) -> Position)
-> (String, Pos String)
-> LineNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos String -> Position
forall a. Pos a -> Position
posPostion (Pos String -> Position)
-> ((String, Pos String) -> Pos String)
-> (String, Pos String)
-> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Pos String) -> Pos String
forall a b. (a, b) -> b
snd) ([(String, Pos String)] -> Maybe (String, Pos String))
-> [(String, Pos String)] -> Maybe (String, Pos String)
forall a b. (a -> b) -> a -> b
$
      Map String (Pos String) -> [(String, Pos String)]
forall k a. Map k a -> [(k, a)]
Map.toList (String -> String -> Map String (Pos String)
findDeclarations String
path String
file)

readFileSafe :: MonadIO m => FilePath -> m (Maybe String)
readFileSafe :: String -> m (Maybe String)
readFileSafe path :: String
path =
  IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$
    (IOException -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(IOException
_ :: IOException) -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
path)

takeHead :: [a] -> Maybe a
takeHead :: [a] -> Maybe a
takeHead = \case
  [] ->
    Maybe a
forall a. Maybe a
Nothing
  x :: a
x : _ ->
    a -> Maybe a
forall a. a -> Maybe a
Just a
x

findProperties :: String -> FilePath -> String -> Map PropertyName PropertySource
findProperties :: String -> String -> String -> Map PropertyName PropertySource
findProperties prefix :: String
prefix path :: String
path =
  (Pos String -> PropertySource)
-> Map PropertyName (Pos String) -> Map PropertyName PropertySource
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Pos String -> PropertySource
PropertySource (Map PropertyName (Pos String) -> Map PropertyName PropertySource)
-> (String -> Map PropertyName (Pos String))
-> String
-> Map PropertyName PropertySource
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (String -> PropertyName)
-> Map String (Pos String) -> Map PropertyName (Pos String)
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic String -> PropertyName
PropertyName (Map String (Pos String) -> Map PropertyName (Pos String))
-> (String -> Map String (Pos String))
-> String
-> Map PropertyName (Pos String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (String -> Pos String -> Bool)
-> Map String (Pos String) -> Map String (Pos String)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\k :: String
k _ -> String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
prefix String
k) (Map String (Pos String) -> Map String (Pos String))
-> (String -> Map String (Pos String))
-> String
-> Map String (Pos String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> Map String (Pos String)
findDeclarations String
path

findDeclarations :: FilePath -> String -> Map String (Pos String)
findDeclarations :: String -> String -> Map String (Pos String)
findDeclarations path :: String
path =
  [Classified (Pos Char)] -> Map String (Pos String)
declarations ([Classified (Pos Char)] -> Map String (Pos String))
-> (String -> [Classified (Pos Char)])
-> String
-> Map String (Pos String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  [Pos Char] -> [Classified (Pos Char)]
classified ([Pos Char] -> [Classified (Pos Char)])
-> (String -> [Pos Char]) -> String -> [Classified (Pos Char)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> [Pos Char]
positioned String
path

------------------------------------------------------------------------
-- Declaration Identification

declarations :: [Classified (Pos Char)] -> Map String (Pos String)
declarations :: [Classified (Pos Char)] -> Map String (Pos String)
declarations =
  let
    loop :: [Classified (Pos Char)] -> [(String, Pos String)]
loop = \case
      [] ->
        []
      x :: Classified (Pos Char)
x : xs :: [Classified (Pos Char)]
xs ->
        let
          (ys :: [Classified (Pos Char)]
ys, zs :: [Classified (Pos Char)]
zs) =
            (Classified (Pos Char) -> Bool)
-> [Classified (Pos Char)]
-> ([Classified (Pos Char)], [Classified (Pos Char)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Classified (Pos Char) -> Bool
isDeclaration [Classified (Pos Char)]
xs
        in
          Pos String -> (String, Pos String)
tagWithName (Classified (Pos Char) -> [Classified (Pos Char)] -> Pos String
forget Classified (Pos Char)
x ([Classified (Pos Char)] -> Pos String)
-> [Classified (Pos Char)] -> Pos String
forall a b. (a -> b) -> a -> b
$ [Classified (Pos Char)] -> [Classified (Pos Char)]
trimEnd [Classified (Pos Char)]
ys) (String, Pos String)
-> [(String, Pos String)] -> [(String, Pos String)]
forall a. a -> [a] -> [a]
: [Classified (Pos Char)] -> [(String, Pos String)]
loop [Classified (Pos Char)]
zs
  in
    (Pos String -> Pos String -> Pos String)
-> [(String, Pos String)] -> Map String (Pos String)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Pos String -> Pos String -> Pos String
forall a. Semigroup a => a -> a -> a
(<>) ([(String, Pos String)] -> Map String (Pos String))
-> ([Classified (Pos Char)] -> [(String, Pos String)])
-> [Classified (Pos Char)]
-> Map String (Pos String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Classified (Pos Char)] -> [(String, Pos String)]
loop ([Classified (Pos Char)] -> [(String, Pos String)])
-> ([Classified (Pos Char)] -> [Classified (Pos Char)])
-> [Classified (Pos Char)]
-> [(String, Pos String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Classified (Pos Char) -> Bool)
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool)
-> (Classified (Pos Char) -> Bool) -> Classified (Pos Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Classified (Pos Char) -> Bool
isDeclaration)

trimEnd :: [Classified (Pos Char)] -> [Classified (Pos Char)]
trimEnd :: [Classified (Pos Char)] -> [Classified (Pos Char)]
trimEnd xs :: [Classified (Pos Char)]
xs =
  let
    (space0 :: [Classified (Pos Char)]
space0, code :: [Classified (Pos Char)]
code) =
      (Classified (Pos Char) -> Bool)
-> [Classified (Pos Char)]
-> ([Classified (Pos Char)], [Classified (Pos Char)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Classified (Pos Char) -> Bool
isWhitespace ([Classified (Pos Char)]
 -> ([Classified (Pos Char)], [Classified (Pos Char)]))
-> [Classified (Pos Char)]
-> ([Classified (Pos Char)], [Classified (Pos Char)])
forall a b. (a -> b) -> a -> b
$ [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. [a] -> [a]
reverse [Classified (Pos Char)]
xs

    (line_tail0 :: [Classified (Pos Char)]
line_tail0, space :: [Classified (Pos Char)]
space) =
      (Classified (Pos Char) -> Bool)
-> [Classified (Pos Char)]
-> ([Classified (Pos Char)], [Classified (Pos Char)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\(Classified _ (Pos _ x :: Char
x)) -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n') ([Classified (Pos Char)]
 -> ([Classified (Pos Char)], [Classified (Pos Char)]))
-> [Classified (Pos Char)]
-> ([Classified (Pos Char)], [Classified (Pos Char)])
forall a b. (a -> b) -> a -> b
$
      [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. [a] -> [a]
reverse [Classified (Pos Char)]
space0

    line_tail :: [Classified (Pos Char)]
line_tail =
      case [Classified (Pos Char)]
space of
        [] ->
          [Classified (Pos Char)]
line_tail0
        x :: Classified (Pos Char)
x : _ ->
          [Classified (Pos Char)]
line_tail0 [Classified (Pos Char)]
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. [a] -> [a] -> [a]
++ [Classified (Pos Char)
x]
  in
    [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. [a] -> [a]
reverse [Classified (Pos Char)]
code [Classified (Pos Char)]
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. [a] -> [a] -> [a]
++ [Classified (Pos Char)]
line_tail

isWhitespace :: Classified (Pos Char) -> Bool
isWhitespace :: Classified (Pos Char) -> Bool
isWhitespace (Classified c :: Class
c (Pos _ x :: Char
x)) =
  Class
c Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
Comment Bool -> Bool -> Bool
||
  Char -> Bool
Char.isSpace Char
x

tagWithName :: Pos String -> (String, Pos String)
tagWithName :: Pos String -> (String, Pos String)
tagWithName (Pos p :: Position
p x :: String
x) =
  (ShowS
takeName String
x, Position -> String -> Pos String
forall a. Position -> a -> Pos a
Pos Position
p String
x)

takeName :: String -> String
takeName :: ShowS
takeName xs :: String
xs =
  case String -> [String]
words String
xs of
    [] ->
      ""
    x :: String
x : _ ->
      String
x

forget :: Classified (Pos Char) -> [Classified (Pos Char)] -> Pos String
forget :: Classified (Pos Char) -> [Classified (Pos Char)] -> Pos String
forget (Classified _ (Pos p :: Position
p x :: Char
x)) xs :: [Classified (Pos Char)]
xs =
  Position -> String -> Pos String
forall a. Position -> a -> Pos a
Pos Position
p (String -> Pos String) -> String -> Pos String
forall a b. (a -> b) -> a -> b
$
    Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: (Classified (Pos Char) -> Char)
-> [Classified (Pos Char)] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pos Char -> Char
forall a. Pos a -> a
posValue (Pos Char -> Char)
-> (Classified (Pos Char) -> Pos Char)
-> Classified (Pos Char)
-> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Classified (Pos Char) -> Pos Char
forall a. Classified a -> a
classifiedValue) [Classified (Pos Char)]
xs

isDeclaration :: Classified (Pos Char) -> Bool
isDeclaration :: Classified (Pos Char) -> Bool
isDeclaration (Classified c :: Class
c (Pos p :: Position
p x :: Char
x)) =
  Class
c Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
NotComment Bool -> Bool -> Bool
&&
  Position -> ColumnNo
posColumn Position
p ColumnNo -> ColumnNo -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
&&
  (Char -> Bool
Char.isLower Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_')

------------------------------------------------------------------------
-- Comment Classification

data Class =
    NotComment
  | Comment
    deriving (Class -> Class -> Bool
(Class -> Class -> Bool) -> (Class -> Class -> Bool) -> Eq Class
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Class -> Class -> Bool
$c/= :: Class -> Class -> Bool
== :: Class -> Class -> Bool
$c== :: Class -> Class -> Bool
Eq, Eq Class
Eq Class =>
(Class -> Class -> Ordering)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Class)
-> (Class -> Class -> Class)
-> Ord Class
Class -> Class -> Bool
Class -> Class -> Ordering
Class -> Class -> Class
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Class -> Class -> Class
$cmin :: Class -> Class -> Class
max :: Class -> Class -> Class
$cmax :: Class -> Class -> Class
>= :: Class -> Class -> Bool
$c>= :: Class -> Class -> Bool
> :: Class -> Class -> Bool
$c> :: Class -> Class -> Bool
<= :: Class -> Class -> Bool
$c<= :: Class -> Class -> Bool
< :: Class -> Class -> Bool
$c< :: Class -> Class -> Bool
compare :: Class -> Class -> Ordering
$ccompare :: Class -> Class -> Ordering
$cp1Ord :: Eq Class
Ord, Int -> Class -> ShowS
[Class] -> ShowS
Class -> String
(Int -> Class -> ShowS)
-> (Class -> String) -> ([Class] -> ShowS) -> Show Class
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Class] -> ShowS
$cshowList :: [Class] -> ShowS
show :: Class -> String
$cshow :: Class -> String
showsPrec :: Int -> Class -> ShowS
$cshowsPrec :: Int -> Class -> ShowS
Show)

data Classified a =
  Classified {
      Classified a -> Class
_classifiedClass :: !Class
    , Classified a -> a
classifiedValue :: !a
    } deriving (Classified a -> Classified a -> Bool
(Classified a -> Classified a -> Bool)
-> (Classified a -> Classified a -> Bool) -> Eq (Classified a)
forall a. Eq a => Classified a -> Classified a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Classified a -> Classified a -> Bool
$c/= :: forall a. Eq a => Classified a -> Classified a -> Bool
== :: Classified a -> Classified a -> Bool
$c== :: forall a. Eq a => Classified a -> Classified a -> Bool
Eq, Eq (Classified a)
Eq (Classified a) =>
(Classified a -> Classified a -> Ordering)
-> (Classified a -> Classified a -> Bool)
-> (Classified a -> Classified a -> Bool)
-> (Classified a -> Classified a -> Bool)
-> (Classified a -> Classified a -> Bool)
-> (Classified a -> Classified a -> Classified a)
-> (Classified a -> Classified a -> Classified a)
-> Ord (Classified a)
Classified a -> Classified a -> Bool
Classified a -> Classified a -> Ordering
Classified a -> Classified a -> Classified a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Classified a)
forall a. Ord a => Classified a -> Classified a -> Bool
forall a. Ord a => Classified a -> Classified a -> Ordering
forall a. Ord a => Classified a -> Classified a -> Classified a
min :: Classified a -> Classified a -> Classified a
$cmin :: forall a. Ord a => Classified a -> Classified a -> Classified a
max :: Classified a -> Classified a -> Classified a
$cmax :: forall a. Ord a => Classified a -> Classified a -> Classified a
>= :: Classified a -> Classified a -> Bool
$c>= :: forall a. Ord a => Classified a -> Classified a -> Bool
> :: Classified a -> Classified a -> Bool
$c> :: forall a. Ord a => Classified a -> Classified a -> Bool
<= :: Classified a -> Classified a -> Bool
$c<= :: forall a. Ord a => Classified a -> Classified a -> Bool
< :: Classified a -> Classified a -> Bool
$c< :: forall a. Ord a => Classified a -> Classified a -> Bool
compare :: Classified a -> Classified a -> Ordering
$ccompare :: forall a. Ord a => Classified a -> Classified a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Classified a)
Ord, Int -> Classified a -> ShowS
[Classified a] -> ShowS
Classified a -> String
(Int -> Classified a -> ShowS)
-> (Classified a -> String)
-> ([Classified a] -> ShowS)
-> Show (Classified a)
forall a. Show a => Int -> Classified a -> ShowS
forall a. Show a => [Classified a] -> ShowS
forall a. Show a => Classified a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Classified a] -> ShowS
$cshowList :: forall a. Show a => [Classified a] -> ShowS
show :: Classified a -> String
$cshow :: forall a. Show a => Classified a -> String
showsPrec :: Int -> Classified a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Classified a -> ShowS
Show)

classified :: [Pos Char] -> [Classified (Pos Char)]
classified :: [Pos Char] -> [Classified (Pos Char)]
classified =
  let
    ok :: a -> Classified a
ok =
      Class -> a -> Classified a
forall a. Class -> a -> Classified a
Classified Class
NotComment

    ko :: a -> Classified a
ko =
      Class -> a -> Classified a
forall a. Class -> a -> Classified a
Classified Class
Comment

    loop :: a -> Bool -> [Pos Char] -> [Classified (Pos Char)]
loop nesting :: a
nesting in_line :: Bool
in_line = \case
      [] ->
        []

      x :: Pos Char
x@(Pos _ '\n') : xs :: [Pos Char]
xs | Bool
in_line ->
        Pos Char -> Classified (Pos Char)
forall a. a -> Classified a
ok Pos Char
x Classified (Pos Char)
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. a -> [a] -> [a]
: a -> Bool -> [Pos Char] -> [Classified (Pos Char)]
loop a
nesting Bool
False [Pos Char]
xs

      x :: Pos Char
x : xs :: [Pos Char]
xs | Bool
in_line ->
        Pos Char -> Classified (Pos Char)
forall a. a -> Classified a
ko Pos Char
x Classified (Pos Char)
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. a -> [a] -> [a]
: a -> Bool -> [Pos Char] -> [Classified (Pos Char)]
loop a
nesting Bool
in_line [Pos Char]
xs

      x :: Pos Char
x@(Pos _ '{') : y :: Pos Char
y@(Pos _ '-') : xs :: [Pos Char]
xs ->
        Pos Char -> Classified (Pos Char)
forall a. a -> Classified a
ko Pos Char
x Classified (Pos Char)
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. a -> [a] -> [a]
: Pos Char -> Classified (Pos Char)
forall a. a -> Classified a
ko Pos Char
y Classified (Pos Char)
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. a -> [a] -> [a]
: a -> Bool -> [Pos Char] -> [Classified (Pos Char)]
loop (a
nesting a -> a -> a
forall a. Num a => a -> a -> a
+ 1) Bool
in_line [Pos Char]
xs

      x :: Pos Char
x@(Pos _ '-') : y :: Pos Char
y@(Pos _ '}') : xs :: [Pos Char]
xs | a
nesting a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> 0 ->
        Pos Char -> Classified (Pos Char)
forall a. a -> Classified a
ko Pos Char
x Classified (Pos Char)
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. a -> [a] -> [a]
: Pos Char -> Classified (Pos Char)
forall a. a -> Classified a
ko Pos Char
y Classified (Pos Char)
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. a -> [a] -> [a]
: a -> Bool -> [Pos Char] -> [Classified (Pos Char)]
loop (a
nesting a -> a -> a
forall a. Num a => a -> a -> a
- 1) Bool
in_line [Pos Char]
xs

      x :: Pos Char
x : xs :: [Pos Char]
xs | a
nesting a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> 0 ->
        Pos Char -> Classified (Pos Char)
forall a. a -> Classified a
ko Pos Char
x Classified (Pos Char)
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. a -> [a] -> [a]
: a -> Bool -> [Pos Char] -> [Classified (Pos Char)]
loop a
nesting Bool
in_line [Pos Char]
xs

      -- FIXME This is not technically correct, we should allow arbitrary runs
      -- FIXME of dashes followed by a symbol character. Here we have only
      -- FIXME allowed two.
      x :: Pos Char
x@(Pos _ '-') : y :: Pos Char
y@(Pos _ '-') : z :: Pos Char
z@(Pos _ zz :: Char
zz) : xs :: [Pos Char]
xs
        | Bool -> Bool
not (Char -> Bool
Char.isSymbol Char
zz)
        ->
          Pos Char -> Classified (Pos Char)
forall a. a -> Classified a
ko Pos Char
x Classified (Pos Char)
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. a -> [a] -> [a]
: Pos Char -> Classified (Pos Char)
forall a. a -> Classified a
ko Pos Char
y Classified (Pos Char)
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. a -> [a] -> [a]
: a -> Bool -> [Pos Char] -> [Classified (Pos Char)]
loop a
nesting Bool
True (Pos Char
z Pos Char -> [Pos Char] -> [Pos Char]
forall a. a -> [a] -> [a]
: [Pos Char]
xs)

      x :: Pos Char
x : xs :: [Pos Char]
xs ->
        Pos Char -> Classified (Pos Char)
forall a. a -> Classified a
ok Pos Char
x Classified (Pos Char)
-> [Classified (Pos Char)] -> [Classified (Pos Char)]
forall a. a -> [a] -> [a]
: a -> Bool -> [Pos Char] -> [Classified (Pos Char)]
loop a
nesting Bool
in_line [Pos Char]
xs
  in
    Int -> Bool -> [Pos Char] -> [Classified (Pos Char)]
forall a.
(Num a, Ord a) =>
a -> Bool -> [Pos Char] -> [Classified (Pos Char)]
loop (0 :: Int) Bool
False

------------------------------------------------------------------------
-- Character Positioning

data Position =
  Position {
      Position -> String
_posPath :: !FilePath
    , Position -> LineNo
posLine :: !LineNo
    , Position -> ColumnNo
posColumn :: !ColumnNo
    } deriving (Position -> Position -> Bool
(Position -> Position -> Bool)
-> (Position -> Position -> Bool) -> Eq Position
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c== :: Position -> Position -> Bool
Eq, Eq Position
Eq Position =>
(Position -> Position -> Ordering)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Position)
-> (Position -> Position -> Position)
-> Ord Position
Position -> Position -> Bool
Position -> Position -> Ordering
Position -> Position -> Position
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Position -> Position -> Position
$cmin :: Position -> Position -> Position
max :: Position -> Position -> Position
$cmax :: Position -> Position -> Position
>= :: Position -> Position -> Bool
$c>= :: Position -> Position -> Bool
> :: Position -> Position -> Bool
$c> :: Position -> Position -> Bool
<= :: Position -> Position -> Bool
$c<= :: Position -> Position -> Bool
< :: Position -> Position -> Bool
$c< :: Position -> Position -> Bool
compare :: Position -> Position -> Ordering
$ccompare :: Position -> Position -> Ordering
$cp1Ord :: Eq Position
Ord, Int -> Position -> ShowS
[Position] -> ShowS
Position -> String
(Int -> Position -> ShowS)
-> (Position -> String) -> ([Position] -> ShowS) -> Show Position
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Position] -> ShowS
$cshowList :: [Position] -> ShowS
show :: Position -> String
$cshow :: Position -> String
showsPrec :: Int -> Position -> ShowS
$cshowsPrec :: Int -> Position -> ShowS
Show)

data Pos a =
  Pos {
      Pos a -> Position
posPostion :: !Position
    , Pos a -> a
posValue :: a
    } deriving (Pos a -> Pos a -> Bool
(Pos a -> Pos a -> Bool) -> (Pos a -> Pos a -> Bool) -> Eq (Pos a)
forall a. Eq a => Pos a -> Pos a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pos a -> Pos a -> Bool
$c/= :: forall a. Eq a => Pos a -> Pos a -> Bool
== :: Pos a -> Pos a -> Bool
$c== :: forall a. Eq a => Pos a -> Pos a -> Bool
Eq, Eq (Pos a)
Eq (Pos a) =>
(Pos a -> Pos a -> Ordering)
-> (Pos a -> Pos a -> Bool)
-> (Pos a -> Pos a -> Bool)
-> (Pos a -> Pos a -> Bool)
-> (Pos a -> Pos a -> Bool)
-> (Pos a -> Pos a -> Pos a)
-> (Pos a -> Pos a -> Pos a)
-> Ord (Pos a)
Pos a -> Pos a -> Bool
Pos a -> Pos a -> Ordering
Pos a -> Pos a -> Pos a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Pos a)
forall a. Ord a => Pos a -> Pos a -> Bool
forall a. Ord a => Pos a -> Pos a -> Ordering
forall a. Ord a => Pos a -> Pos a -> Pos a
min :: Pos a -> Pos a -> Pos a
$cmin :: forall a. Ord a => Pos a -> Pos a -> Pos a
max :: Pos a -> Pos a -> Pos a
$cmax :: forall a. Ord a => Pos a -> Pos a -> Pos a
>= :: Pos a -> Pos a -> Bool
$c>= :: forall a. Ord a => Pos a -> Pos a -> Bool
> :: Pos a -> Pos a -> Bool
$c> :: forall a. Ord a => Pos a -> Pos a -> Bool
<= :: Pos a -> Pos a -> Bool
$c<= :: forall a. Ord a => Pos a -> Pos a -> Bool
< :: Pos a -> Pos a -> Bool
$c< :: forall a. Ord a => Pos a -> Pos a -> Bool
compare :: Pos a -> Pos a -> Ordering
$ccompare :: forall a. Ord a => Pos a -> Pos a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Pos a)
Ord, Int -> Pos a -> ShowS
[Pos a] -> ShowS
Pos a -> String
(Int -> Pos a -> ShowS)
-> (Pos a -> String) -> ([Pos a] -> ShowS) -> Show (Pos a)
forall a. Show a => Int -> Pos a -> ShowS
forall a. Show a => [Pos a] -> ShowS
forall a. Show a => Pos a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pos a] -> ShowS
$cshowList :: forall a. Show a => [Pos a] -> ShowS
show :: Pos a -> String
$cshow :: forall a. Show a => Pos a -> String
showsPrec :: Int -> Pos a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Pos a -> ShowS
Show, a -> Pos b -> Pos a
(a -> b) -> Pos a -> Pos b
(forall a b. (a -> b) -> Pos a -> Pos b)
-> (forall a b. a -> Pos b -> Pos a) -> Functor Pos
forall a b. a -> Pos b -> Pos a
forall a b. (a -> b) -> Pos a -> Pos b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Pos b -> Pos a
$c<$ :: forall a b. a -> Pos b -> Pos a
fmap :: (a -> b) -> Pos a -> Pos b
$cfmap :: forall a b. (a -> b) -> Pos a -> Pos b
Functor)

instance Semigroup a => Semigroup (Pos a) where
  <> :: Pos a -> Pos a -> Pos a
(<>) (Pos p :: Position
p x :: a
x) (Pos q :: Position
q y :: a
y) =
    if Position
p Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
< Position
q then
      Position -> a -> Pos a
forall a. Position -> a -> Pos a
Pos Position
p (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y)
    else
      Position -> a -> Pos a
forall a. Position -> a -> Pos a
Pos Position
q (a
y a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x)

positioned :: FilePath -> [Char] -> [Pos Char]
positioned :: String -> String -> [Pos Char]
positioned path :: String
path =
  let
    loop :: LineNo -> ColumnNo -> String -> [Pos Char]
loop l :: LineNo
l c :: ColumnNo
c = \case
      [] ->
        []

      '\n' : xs :: String
xs ->
        Position -> Char -> Pos Char
forall a. Position -> a -> Pos a
Pos (String -> LineNo -> ColumnNo -> Position
Position String
path LineNo
l ColumnNo
c) '\n' Pos Char -> [Pos Char] -> [Pos Char]
forall a. a -> [a] -> [a]
: LineNo -> ColumnNo -> String -> [Pos Char]
loop (LineNo
l LineNo -> LineNo -> LineNo
forall a. Num a => a -> a -> a
+ 1) 1 String
xs

      x :: Char
x : xs :: String
xs ->
        Position -> Char -> Pos Char
forall a. Position -> a -> Pos a
Pos (String -> LineNo -> ColumnNo -> Position
Position String
path LineNo
l ColumnNo
c) Char
x Pos Char -> [Pos Char] -> [Pos Char]
forall a. a -> [a] -> [a]
: LineNo -> ColumnNo -> String -> [Pos Char]
loop LineNo
l (ColumnNo
c ColumnNo -> ColumnNo -> ColumnNo
forall a. Num a => a -> a -> a
+ 1) String
xs
  in
    LineNo -> ColumnNo -> String -> [Pos Char]
loop 1 1