{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
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           Hedgehog.Internal.Property (PropertyName(..))
import           Hedgehog.Internal.Source (LineNo(..), ColumnNo(..))

#if __GLASGOW_HASKELL__ < 808
import           Data.Semigroup (Semigroup(..))
#endif

------------------------------------------------------------------------
-- 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
$c== :: PropertySource -> PropertySource -> Bool
== :: PropertySource -> PropertySource -> Bool
$c/= :: PropertySource -> PropertySource -> Bool
/= :: 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
$ccompare :: PropertySource -> PropertySource -> Ordering
compare :: PropertySource -> PropertySource -> Ordering
$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
>= :: PropertySource -> PropertySource -> Bool
$cmax :: PropertySource -> PropertySource -> PropertySource
max :: PropertySource -> PropertySource -> PropertySource
$cmin :: PropertySource -> PropertySource -> PropertySource
min :: PropertySource -> PropertySource -> 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
$cshowsPrec :: Int -> PropertySource -> ShowS
showsPrec :: Int -> PropertySource -> ShowS
$cshow :: PropertySource -> String
show :: PropertySource -> String
$cshowList :: [PropertySource] -> ShowS
showList :: [PropertySource] -> ShowS
Show)

readProperties :: MonadIO m => String -> FilePath -> m (Map PropertyName PropertySource)
readProperties :: forall (m :: * -> *).
MonadIO m =>
String -> String -> m (Map PropertyName PropertySource)
readProperties String
prefix 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 a. IO a -> m a
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 :: forall (m :: * -> *).
MonadIO m =>
String -> LineNo -> m (Maybe (String, Pos String))
readDeclaration String
path LineNo
line = do
  Maybe String
mfile <- IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
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 a. a -> m a
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 :: forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
readFileSafe String
path =
  IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
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 a. a -> IO a
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 :: forall a. [a] -> Maybe a
takeHead = \case
  [] ->
    Maybe a
forall a. Maybe a
Nothing
  a
x : [a]
_ ->
    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 String
prefix 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 (\String
k Pos String
_ -> 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 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
      [] ->
        []
      Classified (Pos Char)
x : [Classified (Pos Char)]
xs ->
        let
          ([Classified (Pos Char)]
ys, [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 [Classified (Pos Char)]
xs =
  let
    ([Classified (Pos Char)]
space0, [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

    ([Classified (Pos Char)]
line_tail0, [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 Class
_ (Pos Position
_ Char
x)) -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\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
        Classified (Pos Char)
x : [Classified (Pos Char)]
_ ->
          [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 Class
c (Pos Position
_ 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 Position
p 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 String
xs =
  case String -> [String]
words String
xs of
    [] ->
      String
""
    String
x : [String]
_ ->
      String
x

forget :: Classified (Pos Char) -> [Classified (Pos Char)] -> Pos String
forget :: Classified (Pos Char) -> [Classified (Pos Char)] -> Pos String
forget (Classified Class
_ (Pos Position
p Char
x)) [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 a b. (a -> b) -> [a] -> [b]
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 Class
c (Pos Position
p 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
== ColumnNo
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
== Char
'_')

------------------------------------------------------------------------
-- 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
$c== :: Class -> Class -> Bool
== :: Class -> Class -> Bool
$c/= :: Class -> Class -> Bool
/= :: 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
$ccompare :: Class -> Class -> Ordering
compare :: Class -> Class -> Ordering
$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
>= :: Class -> Class -> Bool
$cmax :: Class -> Class -> Class
max :: Class -> Class -> Class
$cmin :: Class -> Class -> Class
min :: Class -> Class -> 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
$cshowsPrec :: Int -> Class -> ShowS
showsPrec :: Int -> Class -> ShowS
$cshow :: Class -> String
show :: Class -> String
$cshowList :: [Class] -> ShowS
showList :: [Class] -> ShowS
Show)

data Classified a =
  Classified {
      forall a. Classified a -> Class
_classifiedClass :: !Class
    , forall a. 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
$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
/= :: 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
$ccompare :: forall a. Ord a => Classified a -> Classified a -> Ordering
compare :: Classified a -> Classified a -> Ordering
$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
>= :: Classified a -> Classified a -> Bool
$cmax :: forall a. Ord a => Classified a -> Classified a -> Classified a
max :: Classified a -> Classified a -> Classified a
$cmin :: forall a. Ord a => Classified a -> Classified a -> Classified a
min :: Classified a -> Classified a -> 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
$cshowsPrec :: forall a. Show a => Int -> Classified a -> ShowS
showsPrec :: Int -> Classified a -> ShowS
$cshow :: forall a. Show a => Classified a -> String
show :: Classified a -> String
$cshowList :: forall a. Show a => [Classified a] -> ShowS
showList :: [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 a
nesting Bool
in_line = \case
      [] ->
        []

      x :: Pos Char
x@(Pos Position
_ Char
'\n') : [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

      Pos Char
x : [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 Position
_ Char
'{') : y :: Pos Char
y@(Pos Position
_ Char
'-') : [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
+ a
1) Bool
in_line [Pos Char]
xs

      x :: Pos Char
x@(Pos Position
_ Char
'-') : y :: Pos Char
y@(Pos Position
_ Char
'}') : [Pos Char]
xs | a
nesting a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
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
- a
1) Bool
in_line [Pos Char]
xs

      Pos Char
x : [Pos Char]
xs | a
nesting a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
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 Position
_ Char
'-') : y :: Pos Char
y@(Pos Position
_ Char
'-') : z :: Pos Char
z@(Pos Position
_ Char
zz) : [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)

      Pos Char
x : [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 (Int
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
$c== :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
/= :: 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
$ccompare :: Position -> Position -> Ordering
compare :: Position -> Position -> Ordering
$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
>= :: Position -> Position -> Bool
$cmax :: Position -> Position -> Position
max :: Position -> Position -> Position
$cmin :: Position -> Position -> Position
min :: Position -> Position -> 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
$cshowsPrec :: Int -> Position -> ShowS
showsPrec :: Int -> Position -> ShowS
$cshow :: Position -> String
show :: Position -> String
$cshowList :: [Position] -> ShowS
showList :: [Position] -> ShowS
Show)

data Pos a =
  Pos {
      forall a. Pos a -> Position
posPostion :: !Position
    , forall a. 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
$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
/= :: 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
$ccompare :: forall a. Ord a => Pos a -> Pos a -> Ordering
compare :: Pos a -> Pos a -> Ordering
$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
>= :: Pos a -> Pos a -> Bool
$cmax :: forall a. Ord a => Pos a -> Pos a -> Pos a
max :: Pos a -> Pos a -> Pos a
$cmin :: forall a. Ord a => Pos a -> Pos a -> Pos a
min :: Pos a -> Pos a -> 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
$cshowsPrec :: forall a. Show a => Int -> Pos a -> ShowS
showsPrec :: Int -> Pos a -> ShowS
$cshow :: forall a. Show a => Pos a -> String
show :: Pos a -> String
$cshowList :: forall a. Show a => [Pos a] -> ShowS
showList :: [Pos a] -> ShowS
Show, (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
$cfmap :: forall a b. (a -> b) -> Pos a -> Pos b
fmap :: forall a b. (a -> b) -> Pos a -> Pos b
$c<$ :: forall a b. a -> Pos b -> Pos a
<$ :: forall a b. a -> Pos b -> Pos a
Functor)

instance Semigroup a => Semigroup (Pos a) where
  <> :: Pos a -> Pos a -> Pos a
(<>) (Pos Position
p a
x) (Pos Position
q 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 String
path =
  let
    loop :: LineNo -> ColumnNo -> String -> [Pos Char]
loop LineNo
l ColumnNo
c = \case
      [] ->
        []

      Char
'\n' : 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
'\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
+ LineNo
1) ColumnNo
1 String
xs

      Char
x : 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
+ ColumnNo
1) String
xs
  in
    LineNo -> ColumnNo -> String -> [Pos Char]
loop LineNo
1 ColumnNo
1