-- | Parser for @.agda-lib@ files.
--
--   Example file:
--
--   @
--     name: Main
--     depend:
--       standard-library
--     include: .
--       src more-src
--
--   @
--
--   Should parse as:
--
--   @
--     AgdaLib
--       { libName     = "Main"
--       , libFile     = path_to_this_file
--       , libIncludes = [ "." , "src" , "more-src" ]
--       , libDepends  = [ "standard-library" ]
--       }
--   @
--
module Agda.Interaction.Library.Parse
  ( parseLibFile
  , splitCommas
  , trimLineComment
  , runP
  ) where

import Control.Monad
import Control.Monad.Except
import Control.Monad.Writer
import Data.Char
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import System.FilePath

import Agda.Interaction.Library.Base

import Agda.Syntax.Position

import Agda.Utils.Applicative
import Agda.Utils.FileName
import Agda.Utils.IO                ( catchIO )
import qualified Agda.Utils.IO.UTF8 as UTF8
import Agda.Utils.Lens
import Agda.Utils.List              ( duplicates )
import Agda.Utils.List1             ( List1, toList )
import qualified Agda.Utils.List1   as List1
import qualified Agda.Utils.Maybe.Strict as Strict
import Agda.Utils.Singleton
import Agda.Utils.String            ( ltrim )

-- | Parser monad: Can throw @LibParseError@s, and collects
-- @LibWarning'@s library warnings.
type P = ExceptT LibParseError (Writer [LibWarning'])

runP :: P a -> (Either LibParseError a, [LibWarning'])
runP :: forall a. P a -> (Either LibParseError a, [LibWarning'])
runP = Writer [LibWarning'] (Either LibParseError a)
-> (Either LibParseError a, [LibWarning'])
forall w a. Writer w a -> (a, w)
runWriter (Writer [LibWarning'] (Either LibParseError a)
 -> (Either LibParseError a, [LibWarning']))
-> (ExceptT LibParseError (Writer [LibWarning']) a
    -> Writer [LibWarning'] (Either LibParseError a))
-> ExceptT LibParseError (Writer [LibWarning']) a
-> (Either LibParseError a, [LibWarning'])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT LibParseError (Writer [LibWarning']) a
-> Writer [LibWarning'] (Either LibParseError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

warningP :: LibWarning' -> P ()
warningP :: LibWarning' -> P ()
warningP = [LibWarning'] -> P ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([LibWarning'] -> P ())
-> (LibWarning' -> [LibWarning']) -> LibWarning' -> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LibWarning' -> [LibWarning']
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | The config files we parse have the generic structure of a sequence
--   of @field : content@ entries.
type GenericFile = [GenericEntry]

data GenericEntry = GenericEntry
  { GenericEntry -> [Char]
geHeader   :: String        -- ^ E.g. field name.    @trim@med.
  , GenericEntry -> [ContentLine]
_geContent :: [ContentLine] -- ^ E.g. field content. @trim@med.
  }

-- | A (part of a) line of field content.
data ContentLine = ContentLine
  { ContentLine -> ColumnNumber
clLine   :: LineNumber
  , ContentLine -> ColumnNumber
clColumn :: ColumnNumber    -- ^ Column (1-based) where 'clText' starts.
  , ContentLine -> [Char]
clText   :: String          -- ^ @trim@med.
  }
  deriving (ColumnNumber -> ContentLine -> ShowS
[ContentLine] -> ShowS
ContentLine -> [Char]
(ColumnNumber -> ContentLine -> ShowS)
-> (ContentLine -> [Char])
-> ([ContentLine] -> ShowS)
-> Show ContentLine
forall a.
(ColumnNumber -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: ColumnNumber -> ContentLine -> ShowS
showsPrec :: ColumnNumber -> ContentLine -> ShowS
$cshow :: ContentLine -> [Char]
show :: ContentLine -> [Char]
$cshowList :: [ContentLine] -> ShowS
showList :: [ContentLine] -> ShowS
Show)

-- | Library file field format format [sic!].
data Field = forall a. Field
  { Field -> [Char]
fName     :: String
      -- ^ Name of the field.
  , Field -> Bool
fOptional :: Bool
      -- ^ Is it optional?
  , ()
fParse    :: Range -> [ContentLine] -> P a
      -- ^ Content parser for this field.
      --
      -- The range points to the start of the file.
  , ()
fSet      :: LensSet AgdaLibFile a
      -- ^ Sets parsed content in 'AgdaLibFile' structure.
  }

optionalField ::
  String -> (Range -> [ContentLine] -> P a) -> Lens' AgdaLibFile a -> Field
optionalField :: forall a.
[Char]
-> (Range -> [ContentLine] -> P a) -> Lens' AgdaLibFile a -> Field
optionalField [Char]
str Range -> [ContentLine] -> P a
p Lens' AgdaLibFile a
l = [Char]
-> Bool
-> (Range -> [ContentLine] -> P a)
-> LensSet AgdaLibFile a
-> Field
forall a.
[Char]
-> Bool
-> (Range -> [ContentLine] -> P a)
-> LensSet AgdaLibFile a
-> Field
Field [Char]
str Bool
True Range -> [ContentLine] -> P a
p (ASetter AgdaLibFile AgdaLibFile a a -> LensSet AgdaLibFile a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter AgdaLibFile AgdaLibFile a a
Lens' AgdaLibFile a
l)

-- | @.agda-lib@ file format with parsers and setters.
agdaLibFields :: [Field]
agdaLibFields :: [Field]
agdaLibFields =
  -- Andreas, 2017-08-23, issue #2708, field "name" is optional.
  [ [Char]
-> (Range -> [ContentLine] -> P LibName)
-> Lens' AgdaLibFile LibName
-> Field
forall a.
[Char]
-> (Range -> [ContentLine] -> P a) -> Lens' AgdaLibFile a -> Field
optionalField [Char]
"name"    (\Range
_ -> [[Char]] -> P LibName
parseName ([[Char]] -> P LibName)
-> ([ContentLine] -> [[Char]]) -> [ContentLine] -> P LibName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContentLine -> [Char]) -> [ContentLine] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ContentLine -> [Char]
clText)                     (LibName -> f LibName) -> AgdaLibFile -> f AgdaLibFile
Lens' AgdaLibFile LibName
libName
  , [Char]
-> (Range -> [ContentLine] -> P [[Char]])
-> Lens' AgdaLibFile [[Char]]
-> Field
forall a.
[Char]
-> (Range -> [ContentLine] -> P a) -> Lens' AgdaLibFile a -> Field
optionalField [Char]
"include" (\Range
_ -> [[Char]] -> P [[Char]]
forall a. a -> ExceptT LibParseError (Writer [LibWarning']) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> P [[Char]])
-> ([ContentLine] -> [[Char]]) -> [ContentLine] -> P [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContentLine -> [[Char]]) -> [ContentLine] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char] -> [[Char]]
parsePaths ([Char] -> [[Char]])
-> (ContentLine -> [Char]) -> ContentLine -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentLine -> [Char]
clText))   ([[Char]] -> f [[Char]]) -> AgdaLibFile -> f AgdaLibFile
Lens' AgdaLibFile [[Char]]
libIncludes
  , [Char]
-> Bool
-> (Range
    -> [ContentLine] -> P ([LibName], Map LibName LibFilePos))
-> LensSet AgdaLibFile ([LibName], Map LibName LibFilePos)
-> Field
forall a.
[Char]
-> Bool
-> (Range -> [ContentLine] -> P a)
-> LensSet AgdaLibFile a
-> Field
Field [Char]
"depend" Bool
True     (\Range
_ -> ([LibName], Map LibName LibFilePos)
-> P ([LibName], Map LibName LibFilePos)
forall a. a -> ExceptT LibParseError (Writer [LibWarning']) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([LibName], Map LibName LibFilePos)
 -> P ([LibName], Map LibName LibFilePos))
-> ([ContentLine] -> ([LibName], Map LibName LibFilePos))
-> [ContentLine]
-> P ([LibName], Map LibName LibFilePos)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ContentLine] -> ([LibName], Map LibName LibFilePos)
parseDepends)
      (\ ([LibName]
ds, Map LibName LibFilePos
pos) AgdaLibFile
l -> AgdaLibFile
l{ _libDepends = ds, _libDependsPos = pos })
  , [Char]
-> (Range -> [ContentLine] -> P OptionsPragma)
-> Lens' AgdaLibFile OptionsPragma
-> Field
forall a.
[Char]
-> (Range -> [ContentLine] -> P a) -> Lens' AgdaLibFile a -> Field
optionalField [Char]
"flags"   (\Range
r -> OptionsPragma -> P OptionsPragma
forall a. a -> ExceptT LibParseError (Writer [LibWarning']) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OptionsPragma -> P OptionsPragma)
-> ([ContentLine] -> OptionsPragma)
-> [ContentLine]
-> P OptionsPragma
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContentLine -> OptionsPragma) -> [ContentLine] -> OptionsPragma
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Range -> [Char] -> OptionsPragma
parseFlags Range
r ([Char] -> OptionsPragma)
-> (ContentLine -> [Char]) -> ContentLine -> OptionsPragma
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentLine -> [Char]
clText)) (OptionsPragma -> f OptionsPragma) -> AgdaLibFile -> f AgdaLibFile
Lens' AgdaLibFile OptionsPragma
libPragmas
  ]
  where
    -- Remember where the dependencies are mentioned (issue #8875).
    parseDepends :: [ContentLine] -> ([LibName], Map LibName LibFilePos)
    parseDepends :: [ContentLine] -> ([LibName], Map LibName LibFilePos)
parseDepends [ContentLine]
cls = (((LibName, LibFilePos) -> LibName)
-> [(LibName, LibFilePos)] -> [LibName]
forall a b. (a -> b) -> [a] -> [b]
map (LibName, LibFilePos) -> LibName
forall a b. (a, b) -> a
fst [(LibName, LibFilePos)]
ds, (LibFilePos -> LibFilePos -> LibFilePos)
-> [(LibName, LibFilePos)] -> Map LibName LibFilePos
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (\ LibFilePos
_new LibFilePos
old -> LibFilePos
old) [(LibName, LibFilePos)]
ds)
      where
        ds :: [(LibName, LibFilePos)]
ds = [ ([Char] -> LibName
parseLibName [Char]
w, ColumnNumber -> ColumnNumber -> ColumnNumber -> LibFilePos
LibFilePos ColumnNumber
l ColumnNumber
c (ColumnNumber
c ColumnNumber -> ColumnNumber -> ColumnNumber
forall a. Num a => a -> a -> a
+ [Char] -> ColumnNumber
forall a. [a] -> ColumnNumber
forall (t :: * -> *) a. Foldable t => t a -> ColumnNumber
length [Char]
w))
             | ContentLine ColumnNumber
l ColumnNumber
c0 [Char]
s <- [ContentLine]
cls
             , (ColumnNumber
c, [Char]
w) <- ColumnNumber -> [Char] -> [(ColumnNumber, [Char])]
splitCommasPos ColumnNumber
c0 [Char]
s
             ]

    parseName :: [String] -> P LibName
    parseName :: [[Char]] -> P LibName
parseName [[Char]
s] | [[Char]
name] <- [Char] -> [[Char]]
words [Char]
s = LibName -> P LibName
forall a. a -> ExceptT LibParseError (Writer [LibWarning']) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LibName -> P LibName) -> LibName -> P LibName
forall a b. (a -> b) -> a -> b
$ [Char] -> LibName
parseLibName [Char]
name
    parseName [[Char]]
ls = LibParseError -> P LibName
forall a.
LibParseError -> ExceptT LibParseError (Writer [LibWarning']) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LibParseError -> P LibName) -> LibParseError -> P LibName
forall a b. (a -> b) -> a -> b
$ [Char] -> LibParseError
BadLibraryName ([Char] -> LibParseError) -> [Char] -> LibParseError
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]]
ls

    parsePaths :: String -> [FilePath]
    parsePaths :: [Char] -> [[Char]]
parsePaths = ShowS -> [Char] -> [[Char]]
go ShowS
forall a. a -> a
id where
      fixup :: ([a] -> t a) -> f (t a)
fixup [a] -> t a
acc = let fp :: t a
fp = [a] -> t a
acc [] in Bool -> Bool
not (t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
fp) Bool -> t a -> f (t a)
forall (f :: * -> *) a. Alternative f => Bool -> a -> f a
?$> t a
fp
      go :: ShowS -> [Char] -> [[Char]]
go ShowS
acc []           = ShowS -> [[Char]]
forall {f :: * -> *} {t :: * -> *} {a} {a}.
(Alternative f, Foldable t) =>
([a] -> t a) -> f (t a)
fixup ShowS
acc
      go ShowS
acc (Char
'\\' : Char
' '  :[Char]
cs) = ShowS -> [Char] -> [[Char]]
go (ShowS
acc ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:)) [Char]
cs
      go ShowS
acc (Char
'\\' : Char
'\\' :[Char]
cs) = ShowS -> [Char] -> [[Char]]
go (ShowS
acc ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:)) [Char]
cs
      go ShowS
acc (       Char
' '  :[Char]
cs) = ShowS -> [[Char]]
forall {f :: * -> *} {t :: * -> *} {a} {a}.
(Alternative f, Foldable t) =>
([a] -> t a) -> f (t a)
fixup ShowS
acc [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ShowS -> [Char] -> [[Char]]
go ShowS
forall a. a -> a
id [Char]
cs
      go ShowS
acc (Char
c           :[Char]
cs) = ShowS -> [Char] -> [[Char]]
go (ShowS
acc ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:)) [Char]
cs

    parseFlags :: Range -> String -> OptionsPragma
    parseFlags :: Range -> [Char] -> OptionsPragma
parseFlags Range
r [Char]
s = OptionsPragma
      { pragmaStrings :: [[Char]]
pragmaStrings = [Char] -> [[Char]]
words [Char]
s
      , pragmaRange :: Range
pragmaRange   = Range
r
      }

-- | Parse @.agda-lib@ file.
--
-- Sets 'libFile' name and turn mentioned include directories into absolute
-- pathes (provided the given 'FilePath' is absolute).
--
parseLibFile :: FilePath -> IO (P AgdaLibFile)
parseLibFile :: [Char] -> IO (P AgdaLibFile)
parseLibFile [Char]
file = do
  abs <- [Char] -> IO AbsolutePath
absolute [Char]
file
  (fmap setPath . parseLib abs <$> UTF8.readFile file) `catchIO` \IOException
e ->
    P AgdaLibFile -> IO (P AgdaLibFile)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (P AgdaLibFile -> IO (P AgdaLibFile))
-> P AgdaLibFile -> IO (P AgdaLibFile)
forall a b. (a -> b) -> a -> b
$ LibParseError -> P AgdaLibFile
forall a.
LibParseError -> ExceptT LibParseError (Writer [LibWarning']) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LibParseError -> P AgdaLibFile) -> LibParseError -> P AgdaLibFile
forall a b. (a -> b) -> a -> b
$ [Char] -> IOException -> LibParseError
ReadFailure [Char]
file IOException
e
  where
    setPath :: AgdaLibFile -> AgdaLibFile
setPath      AgdaLibFile
lib = [Char] -> AgdaLibFile -> AgdaLibFile
unrelativise (ShowS
takeDirectory [Char]
file) (ASetter AgdaLibFile AgdaLibFile [Char] [Char]
-> [Char] -> AgdaLibFile -> AgdaLibFile
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter AgdaLibFile AgdaLibFile [Char] [Char]
Lens' AgdaLibFile [Char]
libFile [Char]
file AgdaLibFile
lib)
    unrelativise :: [Char] -> AgdaLibFile -> AgdaLibFile
unrelativise [Char]
dir = ASetter AgdaLibFile AgdaLibFile [[Char]] [[Char]]
-> ([[Char]] -> [[Char]]) -> AgdaLibFile -> AgdaLibFile
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter AgdaLibFile AgdaLibFile [[Char]] [[Char]]
Lens' AgdaLibFile [[Char]]
libIncludes (ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
dir [Char] -> ShowS
</>))

-- | Parse file contents.
parseLib
  :: AbsolutePath
     -- ^ The parsed file.
  -> String
  -> P AgdaLibFile
parseLib :: AbsolutePath -> [Char] -> P AgdaLibFile
parseLib AbsolutePath
file [Char]
s = AbsolutePath -> GenericFile -> P AgdaLibFile
fromGeneric AbsolutePath
file (GenericFile -> P AgdaLibFile)
-> ExceptT LibParseError (Writer [LibWarning']) GenericFile
-> P AgdaLibFile
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> ExceptT LibParseError (Writer [LibWarning']) GenericFile
parseGeneric [Char]
s

-- | Parse 'GenericFile' with 'agdaLibFields' descriptors.
fromGeneric
  :: AbsolutePath
     -- ^ The parsed file.
  -> GenericFile
  -> P AgdaLibFile
fromGeneric :: AbsolutePath -> GenericFile -> P AgdaLibFile
fromGeneric AbsolutePath
file = AbsolutePath -> [Field] -> GenericFile -> P AgdaLibFile
fromGeneric' AbsolutePath
file [Field]
agdaLibFields

-- | Given a list of 'Field' descriptors (with their custom parsers),
--   parse a 'GenericFile' into the 'AgdaLibFile' structure.
--
--   Checks mandatory fields are present;
--   no duplicate fields, no unknown fields.

fromGeneric'
  :: AbsolutePath
     -- ^ The parsed file.
  -> [Field]
  -> GenericFile
  -> P AgdaLibFile
fromGeneric' :: AbsolutePath -> [Field] -> GenericFile -> P AgdaLibFile
fromGeneric' AbsolutePath
file [Field]
fields GenericFile
fs = do
  [Field] -> [[Char]] -> P ()
checkFields [Field]
fields ((GenericEntry -> [Char]) -> GenericFile -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map GenericEntry -> [Char]
geHeader GenericFile
fs)
  (AgdaLibFile -> GenericEntry -> P AgdaLibFile)
-> AgdaLibFile -> GenericFile -> P AgdaLibFile
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM AgdaLibFile -> GenericEntry -> P AgdaLibFile
upd AgdaLibFile
emptyLibFile GenericFile
fs
  where
    -- The range points to the start of the file.
    r :: Range
    r :: Range
r = AbsolutePath -> Range
forall a. BeginningOfFile a => a -> Range
beginningOfFile AbsolutePath
file
    upd :: AgdaLibFile -> GenericEntry -> P AgdaLibFile
    upd :: AgdaLibFile -> GenericEntry -> P AgdaLibFile
upd AgdaLibFile
l (GenericEntry [Char]
h [ContentLine]
cs) = do
      mf <- [Char] -> [Field] -> P (Maybe Field)
findField [Char]
h [Field]
fields
      case mf of
        Just Field{ Range -> [ContentLine] -> P a
fParse :: ()
fParse :: Range -> [ContentLine] -> P a
fParse, LensSet AgdaLibFile a
fSet :: ()
fSet :: LensSet AgdaLibFile a
fSet } -> do
          x <- Range -> [ContentLine] -> P a
fParse Range
r [ContentLine]
cs
          return $ fSet x l
        Maybe Field
Nothing -> AgdaLibFile -> P AgdaLibFile
forall a. a -> ExceptT LibParseError (Writer [LibWarning']) a
forall (m :: * -> *) a. Monad m => a -> m a
return AgdaLibFile
l

-- | Ensure that there are no duplicate fields and no mandatory fields are missing.
checkFields :: [Field] -> [String] -> P ()
checkFields :: [Field] -> [[Char]] -> P ()
checkFields [Field]
fields [[Char]]
fs = do
  -- Report missing mandatory fields.
  () <- [[Char]] -> (List1 [Char] -> P ()) -> P ()
forall (m :: * -> *) a.
Applicative m =>
[a] -> (List1 a -> m ()) -> m ()
List1.unlessNull [[Char]]
missing ((List1 [Char] -> P ()) -> P ()) -> (List1 [Char] -> P ()) -> P ()
forall a b. (a -> b) -> a -> b
$ LibParseError -> P ()
forall a.
LibParseError -> ExceptT LibParseError (Writer [LibWarning']) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LibParseError -> P ())
-> (List1 [Char] -> LibParseError) -> List1 [Char] -> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 [Char] -> LibParseError
MissingFields
  -- Report duplicate fields.
  List1.unlessNull (duplicates fs) $ throwError . DuplicateFields
  where
  mandatory :: [String]
  mandatory :: [[Char]]
mandatory = [ Field -> [Char]
fName Field
f | Field
f <- [Field]
fields, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Field -> Bool
fOptional Field
f ]
  missing   :: [String]
  missing :: [[Char]]
missing   = [[Char]]
mandatory [[Char]] -> [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [a]
List.\\ [[Char]]
fs

-- | Find 'Field' with given 'fName', throw error if unknown.
findField :: String -> [Field] -> P (Maybe Field)
findField :: [Char] -> [Field] -> P (Maybe Field)
findField [Char]
s [Field]
fs = P (Maybe Field)
-> (Field -> P (Maybe Field)) -> Maybe Field -> P (Maybe Field)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe P (Maybe Field)
err (Maybe Field -> P (Maybe Field)
forall a. a -> ExceptT LibParseError (Writer [LibWarning']) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Field -> P (Maybe Field))
-> (Field -> Maybe Field) -> Field -> P (Maybe Field)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Maybe Field
forall a. a -> Maybe a
Just) (Maybe Field -> P (Maybe Field)) -> Maybe Field -> P (Maybe Field)
forall a b. (a -> b) -> a -> b
$ (Field -> Bool) -> [Field] -> Maybe Field
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (([Char]
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==) ([Char] -> Bool) -> (Field -> [Char]) -> Field -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> [Char]
fName) [Field]
fs
  where err :: P (Maybe Field)
err = LibWarning' -> P ()
warningP ([Char] -> LibWarning'
UnknownField [Char]
s) P () -> P (Maybe Field) -> P (Maybe Field)
forall a b.
ExceptT LibParseError (Writer [LibWarning']) a
-> ExceptT LibParseError (Writer [LibWarning']) b
-> ExceptT LibParseError (Writer [LibWarning']) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Field -> P (Maybe Field)
forall a. a -> ExceptT LibParseError (Writer [LibWarning']) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Field
forall a. Maybe a
Nothing

-- Generic file parser ----------------------------------------------------

-- | Example:
--
-- @
--     parseGeneric "name:Main--BLA\ndepend:--BLA\n  standard-library--BLA\ninclude : . --BLA\n  src more-src   \n"
--     == Right [("name",["Main"]),("depend",["standard-library"]),("include",[".","src more-src"])]
-- @
parseGeneric :: String -> P GenericFile
parseGeneric :: [Char] -> ExceptT LibParseError (Writer [LibWarning']) GenericFile
parseGeneric [Char]
s =
  [GenericLine]
-> ExceptT LibParseError (Writer [LibWarning']) GenericFile
groupLines ([GenericLine]
 -> ExceptT LibParseError (Writer [LibWarning']) GenericFile)
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
-> ExceptT LibParseError (Writer [LibWarning']) GenericFile
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [[GenericLine]] -> [GenericLine]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[GenericLine]] -> [GenericLine])
-> ExceptT LibParseError (Writer [LibWarning']) [[GenericLine]]
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ColumnNumber
 -> [Char]
 -> ExceptT LibParseError (Writer [LibWarning']) [GenericLine])
-> [ColumnNumber]
-> [[Char]]
-> ExceptT LibParseError (Writer [LibWarning']) [[GenericLine]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ColumnNumber
-> [Char]
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
parseLine [ColumnNumber
1..] (ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
stripComments ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines [Char]
s)

-- | Lines with line numbers.
data GenericLine
  = Header  LineNumber String
      -- ^ Header line, like a field name, e.g. "include :".  Cannot be indented.
      --   @String@ is 'trim'med.
  | Content ContentLine
      -- ^ Other line.  Must be indented.
  deriving (ColumnNumber -> GenericLine -> ShowS
[GenericLine] -> ShowS
GenericLine -> [Char]
(ColumnNumber -> GenericLine -> ShowS)
-> (GenericLine -> [Char])
-> ([GenericLine] -> ShowS)
-> Show GenericLine
forall a.
(ColumnNumber -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: ColumnNumber -> GenericLine -> ShowS
showsPrec :: ColumnNumber -> GenericLine -> ShowS
$cshow :: GenericLine -> [Char]
show :: GenericLine -> [Char]
$cshowList :: [GenericLine] -> ShowS
showList :: [GenericLine] -> ShowS
Show)

-- | Parse line into 'Header' and 'Content' components.
--
--   Precondition: line comments and trailing whitespace have been stripped away.
--
--   Example file:
--
--   @
--     name: Main
--     depend:
--       standard-library
--     include: .
--       src more-src
--   @
--
--   This should give
--
--   @
--     [ Header  1 "name"
--     , Content (ContentLine 1 7 "Main")
--     , Header  2 "depend"
--     , Content (ContentLine 3 3 "standard-library")
--     , Header  4 "include"
--     , Content (ContentLine 4 10 ".")
--     , Content (ContentLine 5 3 "src more-src")
--     ]
--   @
parseLine :: LineNumber -> String -> P [GenericLine]
parseLine :: ColumnNumber
-> [Char]
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
parseLine ColumnNumber
_ [Char]
"" = [GenericLine]
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
forall a. a -> ExceptT LibParseError (Writer [LibWarning']) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
parseLine ColumnNumber
l s :: [Char]
s@(Char
c:[Char]
_)
    -- Indented lines are 'Content'.
  | Char -> Bool
isSpace Char
c   = [GenericLine]
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
forall a. a -> ExceptT LibParseError (Writer [LibWarning']) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char] -> GenericLine
content ([Char] -> GenericLine) -> [Char] -> GenericLine
forall a b. (a -> b) -> a -> b
$ ShowS
ltrim [Char]
s]
    -- Non-indented lines are 'Header'.
  | Bool
otherwise   =
    case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') [Char]
s of
      -- Headers are single words followed by a colon.
      -- Anything after the colon that is not whitespace is 'Content'.
      ([Char]
h, Char
':' : [Char]
r) ->
        case [Char] -> [[Char]]
words [Char]
h of
          [[Char]
h] -> [GenericLine]
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
forall a. a -> ExceptT LibParseError (Writer [LibWarning']) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenericLine]
 -> ExceptT LibParseError (Writer [LibWarning']) [GenericLine])
-> [GenericLine]
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
forall a b. (a -> b) -> a -> b
$ ColumnNumber -> [Char] -> GenericLine
Header ColumnNumber
l [Char]
h GenericLine -> [GenericLine] -> [GenericLine]
forall a. a -> [a] -> [a]
: [[Char] -> GenericLine
content [Char]
r' | let r' :: [Char]
r' = ShowS
ltrim [Char]
r, Bool -> Bool
not ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
r')]
          []  -> LibParseError
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
forall a.
LibParseError -> ExceptT LibParseError (Writer [LibWarning']) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LibParseError
 -> ExceptT LibParseError (Writer [LibWarning']) [GenericLine])
-> LibParseError
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
forall a b. (a -> b) -> a -> b
$ ColumnNumber -> LibParseError
MissingFieldName ColumnNumber
l
          [[Char]]
hs  -> LibParseError
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
forall a.
LibParseError -> ExceptT LibParseError (Writer [LibWarning']) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LibParseError
 -> ExceptT LibParseError (Writer [LibWarning']) [GenericLine])
-> LibParseError
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
forall a b. (a -> b) -> a -> b
$ ColumnNumber -> [Char] -> LibParseError
BadFieldName ColumnNumber
l [Char]
h
      ([Char], [Char])
_ -> LibParseError
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
forall a.
LibParseError -> ExceptT LibParseError (Writer [LibWarning']) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LibParseError
 -> ExceptT LibParseError (Writer [LibWarning']) [GenericLine])
-> LibParseError
-> ExceptT LibParseError (Writer [LibWarning']) [GenericLine]
forall a b. (a -> b) -> a -> b
$ ColumnNumber -> [Char] -> LibParseError
MissingColonForField ColumnNumber
l (ShowS
ltrim [Char]
s)
  where
    -- @r@ is a suffix of @s@.
    content :: [Char] -> GenericLine
content [Char]
r = ContentLine -> GenericLine
Content (ContentLine -> GenericLine) -> ContentLine -> GenericLine
forall a b. (a -> b) -> a -> b
$ ColumnNumber -> ColumnNumber -> [Char] -> ContentLine
ContentLine ColumnNumber
l ([Char] -> ColumnNumber
forall a. [a] -> ColumnNumber
forall (t :: * -> *) a. Foldable t => t a -> ColumnNumber
length [Char]
s ColumnNumber -> ColumnNumber -> ColumnNumber
forall a. Num a => a -> a -> a
- [Char] -> ColumnNumber
forall a. [a] -> ColumnNumber
forall (t :: * -> *) a. Foldable t => t a -> ColumnNumber
length [Char]
r ColumnNumber -> ColumnNumber -> ColumnNumber
forall a. Num a => a -> a -> a
+ ColumnNumber
1) [Char]
r

-- | Collect 'Header' and subsequent 'Content's into 'GenericEntry'.
--
--   Leading 'Content's?  That's an error.
--
groupLines :: [GenericLine] -> P GenericFile
groupLines :: [GenericLine]
-> ExceptT LibParseError (Writer [LibWarning']) GenericFile
groupLines [] = GenericFile
-> ExceptT LibParseError (Writer [LibWarning']) GenericFile
forall a. a -> ExceptT LibParseError (Writer [LibWarning']) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
groupLines (Content ContentLine
c : [GenericLine]
_) = LibParseError
-> ExceptT LibParseError (Writer [LibWarning']) GenericFile
forall a.
LibParseError -> ExceptT LibParseError (Writer [LibWarning']) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LibParseError
 -> ExceptT LibParseError (Writer [LibWarning']) GenericFile)
-> LibParseError
-> ExceptT LibParseError (Writer [LibWarning']) GenericFile
forall a b. (a -> b) -> a -> b
$ ColumnNumber -> LibParseError
ContentWithoutField (ColumnNumber -> LibParseError) -> ColumnNumber -> LibParseError
forall a b. (a -> b) -> a -> b
$ ContentLine -> ColumnNumber
clLine ContentLine
c
groupLines (Header ColumnNumber
_ [Char]
h : [GenericLine]
ls) = ([Char] -> [ContentLine] -> GenericEntry
GenericEntry [Char]
h [ ContentLine
c | Content ContentLine
c <- [GenericLine]
cs ] GenericEntry -> GenericFile -> GenericFile
forall a. a -> [a] -> [a]
:) (GenericFile -> GenericFile)
-> ExceptT LibParseError (Writer [LibWarning']) GenericFile
-> ExceptT LibParseError (Writer [LibWarning']) GenericFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenericLine]
-> ExceptT LibParseError (Writer [LibWarning']) GenericFile
groupLines [GenericLine]
ls1
  where
    ([GenericLine]
cs, [GenericLine]
ls1) = (GenericLine -> Bool)
-> [GenericLine] -> ([GenericLine], [GenericLine])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span GenericLine -> Bool
isContent [GenericLine]
ls
    isContent :: GenericLine -> Bool
isContent Content{} = Bool
True
    isContent Header{} = Bool
False

-- | Remove leading whitespace and line comment.
trimLineComment :: String -> String
trimLineComment :: ShowS
trimLineComment = ShowS
stripComments ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
ltrim

-- | Break a comma-separated string.  Result strings are @trim@med.
splitCommas :: String -> [String]
splitCommas :: [Char] -> [[Char]]
splitCommas = ((ColumnNumber, [Char]) -> [Char])
-> [(ColumnNumber, [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (ColumnNumber, [Char]) -> [Char]
forall a b. (a, b) -> b
snd ([(ColumnNumber, [Char])] -> [[Char]])
-> ([Char] -> [(ColumnNumber, [Char])]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnNumber -> [Char] -> [(ColumnNumber, [Char])]
splitCommasPos ColumnNumber
1

-- | Break a comma-separated string starting at the given column.
--   Result strings are @trim@med and come with their starting column.
splitCommasPos :: ColumnNumber -> String -> [(ColumnNumber, String)]
splitCommasPos :: ColumnNumber -> [Char] -> [(ColumnNumber, [Char])]
splitCommasPos ColumnNumber
c0 = [(ColumnNumber, Char)] -> [(ColumnNumber, [Char])]
forall {a}. [(a, Char)] -> [(a, [Char])]
go ([(ColumnNumber, Char)] -> [(ColumnNumber, [Char])])
-> ([Char] -> [(ColumnNumber, Char)])
-> [Char]
-> [(ColumnNumber, [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ColumnNumber] -> [Char] -> [(ColumnNumber, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ColumnNumber
c0..]
  where
    go :: [(a, Char)] -> [(a, [Char])]
go [(a, Char)]
ps = case ((a, Char) -> Bool) -> [(a, Char)] -> [(a, Char)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Bool
isSep (Char -> Bool) -> ((a, Char) -> Char) -> (a, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Char) -> Char
forall a b. (a, b) -> b
snd) [(a, Char)]
ps of
      [] -> []
      ps' :: [(a, Char)]
ps'@((a
c, Char
_) : [(a, Char)]
_) -> let ([(a, Char)]
w, [(a, Char)]
rest) = ((a, Char) -> Bool) -> [(a, Char)] -> ([(a, Char)], [(a, Char)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Bool
isSep (Char -> Bool) -> ((a, Char) -> Char) -> (a, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Char) -> Char
forall a b. (a, b) -> b
snd) [(a, Char)]
ps' in (a
c, ((a, Char) -> Char) -> [(a, Char)] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map (a, Char) -> Char
forall a b. (a, b) -> b
snd [(a, Char)]
w) (a, [Char]) -> [(a, [Char])] -> [(a, [Char])]
forall a. a -> [a] -> [a]
: [(a, Char)] -> [(a, [Char])]
go [(a, Char)]
rest
    isSep :: Char -> Bool
isSep Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c

-- | ...and trailing, but not leading, whitespace.
stripComments :: String -> String
stripComments :: ShowS
stripComments [Char]
"" = [Char]
""
stripComments (Char
'-':Char
'-':Char
c:[Char]
_) | Char -> Bool
isSpace Char
c = [Char]
""
stripComments (Char
c : [Char]
s) = Char -> ShowS
cons Char
c (ShowS
stripComments [Char]
s)
  where
    cons :: Char -> ShowS
cons Char
c [Char]
"" | Char -> Bool
isSpace Char
c = [Char]
""
    cons Char
c [Char]
s = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
s