{- |
Module      :  Camfort.Specification.Parser
Description :  Functionality common to all specification parsers.
Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish
License     :  Apache-2.0

Maintainer  :  dom.orchard@gmail.com
Stability   :  experimental
-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}

module Camfort.Specification.Parser
  (
  -- * Specification Parsers
    SpecParser
  , looksLikeASpec
  , mkParser
  , runParser
  -- ** Errors
  , SpecParseError
  , parseError
  ) where

import           Control.Monad.Except (throwError)
import           Control.Exception (Exception(..))
import           Data.Data
import           Data.List            (isPrefixOf)
import qualified Data.Text            as T

data SpecParseError e
  = ParseError e
  | InvalidSpecificationCharacter Char
  | MissingSpecificationCharacter
  deriving (SpecParseError e -> SpecParseError e -> Bool
(SpecParseError e -> SpecParseError e -> Bool)
-> (SpecParseError e -> SpecParseError e -> Bool)
-> Eq (SpecParseError e)
forall e. Eq e => SpecParseError e -> SpecParseError e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpecParseError e -> SpecParseError e -> Bool
$c/= :: forall e. Eq e => SpecParseError e -> SpecParseError e -> Bool
== :: SpecParseError e -> SpecParseError e -> Bool
$c== :: forall e. Eq e => SpecParseError e -> SpecParseError e -> Bool
Eq, Typeable, Typeable (SpecParseError e)
DataType
Constr
Typeable (SpecParseError e)
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g)
    -> SpecParseError e
    -> c (SpecParseError e))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (SpecParseError e))
-> (SpecParseError e -> Constr)
-> (SpecParseError e -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (SpecParseError e)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (SpecParseError e)))
-> ((forall b. Data b => b -> b)
    -> SpecParseError e -> SpecParseError e)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> SpecParseError e -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> SpecParseError e -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> SpecParseError e -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> SpecParseError e -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> SpecParseError e -> m (SpecParseError e))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> SpecParseError e -> m (SpecParseError e))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> SpecParseError e -> m (SpecParseError e))
-> Data (SpecParseError e)
SpecParseError e -> DataType
SpecParseError e -> Constr
(forall d. Data d => c (t d)) -> Maybe (c (SpecParseError e))
(forall b. Data b => b -> b)
-> SpecParseError e -> SpecParseError e
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SpecParseError e -> c (SpecParseError e)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (SpecParseError e)
forall e. Data e => Typeable (SpecParseError e)
forall e. Data e => SpecParseError e -> DataType
forall e. Data e => SpecParseError e -> Constr
forall e.
Data e =>
(forall b. Data b => b -> b)
-> SpecParseError e -> SpecParseError e
forall e u.
Data e =>
Int -> (forall d. Data d => d -> u) -> SpecParseError e -> u
forall e u.
Data e =>
(forall d. Data d => d -> u) -> SpecParseError e -> [u]
forall e r r'.
Data e =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SpecParseError e -> r
forall e r r'.
Data e =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SpecParseError e -> r
forall e (m :: * -> *).
(Data e, Monad m) =>
(forall d. Data d => d -> m d)
-> SpecParseError e -> m (SpecParseError e)
forall e (m :: * -> *).
(Data e, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> SpecParseError e -> m (SpecParseError e)
forall e (c :: * -> *).
Data e =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (SpecParseError e)
forall e (c :: * -> *).
Data e =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SpecParseError e -> c (SpecParseError e)
forall e (t :: * -> *) (c :: * -> *).
(Data e, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (SpecParseError e))
forall e (t :: * -> * -> *) (c :: * -> *).
(Data e, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (SpecParseError e))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> SpecParseError e -> u
forall u. (forall d. Data d => d -> u) -> SpecParseError e -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SpecParseError e -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SpecParseError e -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> SpecParseError e -> m (SpecParseError e)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> SpecParseError e -> m (SpecParseError e)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (SpecParseError e)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SpecParseError e -> c (SpecParseError e)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (SpecParseError e))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (SpecParseError e))
$cMissingSpecificationCharacter :: Constr
$cInvalidSpecificationCharacter :: Constr
$cParseError :: Constr
$tSpecParseError :: DataType
gmapMo :: (forall d. Data d => d -> m d)
-> SpecParseError e -> m (SpecParseError e)
$cgmapMo :: forall e (m :: * -> *).
(Data e, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> SpecParseError e -> m (SpecParseError e)
gmapMp :: (forall d. Data d => d -> m d)
-> SpecParseError e -> m (SpecParseError e)
$cgmapMp :: forall e (m :: * -> *).
(Data e, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> SpecParseError e -> m (SpecParseError e)
gmapM :: (forall d. Data d => d -> m d)
-> SpecParseError e -> m (SpecParseError e)
$cgmapM :: forall e (m :: * -> *).
(Data e, Monad m) =>
(forall d. Data d => d -> m d)
-> SpecParseError e -> m (SpecParseError e)
gmapQi :: Int -> (forall d. Data d => d -> u) -> SpecParseError e -> u
$cgmapQi :: forall e u.
Data e =>
Int -> (forall d. Data d => d -> u) -> SpecParseError e -> u
gmapQ :: (forall d. Data d => d -> u) -> SpecParseError e -> [u]
$cgmapQ :: forall e u.
Data e =>
(forall d. Data d => d -> u) -> SpecParseError e -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SpecParseError e -> r
$cgmapQr :: forall e r r'.
Data e =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SpecParseError e -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SpecParseError e -> r
$cgmapQl :: forall e r r'.
Data e =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SpecParseError e -> r
gmapT :: (forall b. Data b => b -> b)
-> SpecParseError e -> SpecParseError e
$cgmapT :: forall e.
Data e =>
(forall b. Data b => b -> b)
-> SpecParseError e -> SpecParseError e
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (SpecParseError e))
$cdataCast2 :: forall e (t :: * -> * -> *) (c :: * -> *).
(Data e, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (SpecParseError e))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (SpecParseError e))
$cdataCast1 :: forall e (t :: * -> *) (c :: * -> *).
(Data e, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (SpecParseError e))
dataTypeOf :: SpecParseError e -> DataType
$cdataTypeOf :: forall e. Data e => SpecParseError e -> DataType
toConstr :: SpecParseError e -> Constr
$ctoConstr :: forall e. Data e => SpecParseError e -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (SpecParseError e)
$cgunfold :: forall e (c :: * -> *).
Data e =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (SpecParseError e)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SpecParseError e -> c (SpecParseError e)
$cgfoldl :: forall e (c :: * -> *).
Data e =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SpecParseError e -> c (SpecParseError e)
$cp1Data :: forall e. Data e => Typeable (SpecParseError e)
Data)

instance (Show e) => Show (SpecParseError e) where
  show :: SpecParseError e -> String
show (InvalidSpecificationCharacter Char
c) =
    String
"Invalid character at start of specification: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c
  show SpecParseError e
MissingSpecificationCharacter = String
"missing start of specification"
  show (ParseError e
e) = e -> String
forall a. Show a => a -> String
show e
e

instance Exception e => Exception (SpecParseError e) where
  displayException :: SpecParseError e -> String
displayException (InvalidSpecificationCharacter Char
c) =
    String
"Invalid character at start of specification: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c
  displayException SpecParseError e
MissingSpecificationCharacter = String
"missing start of specification"
  displayException (ParseError e
e) = e -> String
forall e. Exception e => e -> String
displayException e
e

-- | Embed an error as a specification parse error.
parseError :: e -> SpecParseError e
parseError :: e -> SpecParseError e
parseError = e -> SpecParseError e
forall e. e -> SpecParseError e
ParseError

invalidSpecificationCharacter :: Char -> SpecParseError e
invalidSpecificationCharacter :: Char -> SpecParseError e
invalidSpecificationCharacter = Char -> SpecParseError e
forall e. Char -> SpecParseError e
InvalidSpecificationCharacter

missingSpecificationCharacter :: SpecParseError e
missingSpecificationCharacter :: SpecParseError e
missingSpecificationCharacter = SpecParseError e
forall e. SpecParseError e
MissingSpecificationCharacter

-- | Parser for specifications of type @r@ that may fail with error type @e@.
data SpecParser e r = SpecParser
  {
    -- | The underlying parser.
    SpecParser e r -> String -> Either e r
parser       :: String -> Either e r
    -- | A list of keywords that indicate the type of specification (e.g., @"stencil"@ or @"access"@).
  , SpecParser e r -> [String]
specKeywords :: [String]
  }
  deriving (a -> SpecParser e b -> SpecParser e a
(a -> b) -> SpecParser e a -> SpecParser e b
(forall a b. (a -> b) -> SpecParser e a -> SpecParser e b)
-> (forall a b. a -> SpecParser e b -> SpecParser e a)
-> Functor (SpecParser e)
forall a b. a -> SpecParser e b -> SpecParser e a
forall a b. (a -> b) -> SpecParser e a -> SpecParser e b
forall e a b. a -> SpecParser e b -> SpecParser e a
forall e a b. (a -> b) -> SpecParser e a -> SpecParser e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SpecParser e b -> SpecParser e a
$c<$ :: forall e a b. a -> SpecParser e b -> SpecParser e a
fmap :: (a -> b) -> SpecParser e a -> SpecParser e b
$cfmap :: forall e a b. (a -> b) -> SpecParser e a -> SpecParser e b
Functor)

-- | Does the character indicate the start of an abritrary specification?
--
-- These characters are used to help distinguish specifications
-- from normal comments.
isSpecStartChar :: Char -> Bool
isSpecStartChar :: Char -> Bool
isSpecStartChar = (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"=!<>")

-- | Run the given parser on a string to produce a specification
-- (or a reason why it couldn't be parsed).
runParser :: SpecParser e r -> String -> Either (SpecParseError e) r
runParser :: SpecParser e r -> String -> Either (SpecParseError e) r
runParser SpecParser e r
p String
s = case String -> Either (SpecParseError e) String
stripInitial String
s of
                  Right String
s' -> case SpecParser e r -> String -> Either e r
forall e r. SpecParser e r -> String -> Either e r
parser SpecParser e r
p String
s' of
                                Left  e
e -> SpecParseError e -> Either (SpecParseError e) r
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SpecParseError e -> Either (SpecParseError e) r)
-> SpecParseError e -> Either (SpecParseError e) r
forall a b. (a -> b) -> a -> b
$ e -> SpecParseError e
forall e. e -> SpecParseError e
parseError e
e
                                Right r
r -> r -> Either (SpecParseError e) r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
                  Left SpecParseError e
e   -> SpecParseError e -> Either (SpecParseError e) r
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SpecParseError e
e
  where stripInitial :: String -> Either (SpecParseError e) String
stripInitial = String -> Either (SpecParseError e) String
forall e (m :: * -> *).
MonadError (SpecParseError e) m =>
String -> m String
stripAnnChar (String -> Either (SpecParseError e) String)
-> ShowS -> String -> Either (SpecParseError e) String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
stripLeadingWhiteSpace
        stripAnnChar :: String -> m String
stripAnnChar [] =
          SpecParseError e -> m String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SpecParseError e
forall e. SpecParseError e
missingSpecificationCharacter
        stripAnnChar (Char
c:String
cs) | Char -> Bool
isSpecStartChar Char
c = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShowS
stripLeadingWhiteSpace String
cs)
                            | Bool
otherwise         =
                                SpecParseError e -> m String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SpecParseError e -> m String) -> SpecParseError e -> m String
forall a b. (a -> b) -> a -> b
$ Char -> SpecParseError e
forall e. Char -> SpecParseError e
invalidSpecificationCharacter Char
c

-- | Define a specification parser.
mkParser :: (String -> Either e r) -- ^ Parser with error type @e@ and result type @r@.
         -> [String]               -- ^ Keywords that indicate the type of specification.
         -> SpecParser e r
mkParser :: (String -> Either e r) -> [String] -> SpecParser e r
mkParser = (String -> Either e r) -> [String] -> SpecParser e r
forall e r. (String -> Either e r) -> [String] -> SpecParser e r
SpecParser

-- | Remove any whitespace characters at the beginning of the string.
stripLeadingWhiteSpace :: String -> String
stripLeadingWhiteSpace :: ShowS
stripLeadingWhiteSpace = Text -> String
T.unpack (Text -> String) -> (String -> Text) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- | Check if a comment is probably an attempt at a specification
-- that can be parsed by the given parser.
looksLikeASpec :: SpecParser e r -> String -> Bool
looksLikeASpec :: SpecParser e r -> String -> Bool
looksLikeASpec SpecParser e r
p String
text
  | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ShowS
stripLeadingWhiteSpace String
text) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 =
  case ShowS
stripLeadingWhiteSpace String
text of
    -- Check the leading character is '=' for specification
    Char
c:String
cs -> Char -> Bool
isSpecStartChar Char
c Bool -> Bool -> Bool
&& String -> Bool
testAnnotation String
cs
    String
_    -> Bool
False
  | Bool
otherwise = Bool
False
  where
    testAnnotation :: String -> Bool
testAnnotation String
inp = case SpecParser e r -> [String]
forall e r. SpecParser e r -> [String]
specKeywords SpecParser e r
p of
                           [] -> Bool
True
                           [String]
ks -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
inp String -> String -> Bool
`hasPrefix`) [String]
ks
    hasPrefix :: String -> String -> Bool
hasPrefix []       String
_   = Bool
False
    hasPrefix (Char
' ':String
xs) String
str = String -> String -> Bool
hasPrefix String
xs String
str
    hasPrefix String
xs       String
str = String
str String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
xs