{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Deprecated.ParseUtils
-- Copyright   :  (c) The University of Glasgow 2004
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'.
--
-- The @.cabal@ file format is not trivial, especially with the introduction
-- of configurations and the section syntax that goes with that. This module
-- has a bunch of parsing functions that is used by the @.cabal@ parser and a
-- couple others. It has the parsing framework code and also little parsers for
-- many of the formats we get in various @.cabal@ file fields, like module
-- names, comma separated lists etc.

-- This module is meant to be local-only to Distribution...

{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE Rank2Types #-}
module Distribution.Deprecated.ParseUtils (
        LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,
        runP, runE, ParseResult(..), parseFail, showPWarning,
        Field(..), lineNo,
        FieldDescr(..), readFields, readFieldsFlat,
        parseHaskellString, parseFilePathQ, parseTokenQ,
        parseOptCommaList,
        showFilePath, showToken, showFreeText,
        field, simpleField, listField, listFieldWithSep, spaceListField,
        newLineListField,
        liftField,
        readPToMaybe,

        fieldParsec, simpleFieldParsec,
        listFieldParsec,
        commaListFieldParsec,
        commaNewLineListFieldParsec,

        UnrecFieldParser,
  ) where

import Distribution.Client.Compat.Prelude hiding (get)
import Prelude ()

import Distribution.Deprecated.ReadP as ReadP hiding (get)

import Distribution.Pretty
import Distribution.ReadE
import Distribution.Utils.Generic

import Data.Tree as Tree (Tree (..), flatten)
import System.FilePath  (normalise)
import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep)
import qualified Text.Read as Read

import qualified Control.Monad.Fail as Fail
import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingOptCommaList)

-- -----------------------------------------------------------------------------

type LineNo    = Int

data PError = AmbiguousParse String LineNo
            | NoParse String LineNo
            | TabsError LineNo
            | FromString String (Maybe LineNo)
        deriving (PError -> PError -> Bool
(PError -> PError -> Bool)
-> (PError -> PError -> Bool) -> Eq PError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PError -> PError -> Bool
$c/= :: PError -> PError -> Bool
== :: PError -> PError -> Bool
$c== :: PError -> PError -> Bool
Eq, Int -> PError -> ShowS
[PError] -> ShowS
PError -> String
(Int -> PError -> ShowS)
-> (PError -> String) -> ([PError] -> ShowS) -> Show PError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PError] -> ShowS
$cshowList :: [PError] -> ShowS
show :: PError -> String
$cshow :: PError -> String
showsPrec :: Int -> PError -> ShowS
$cshowsPrec :: Int -> PError -> ShowS
Show)

data PWarning = PWarning String
              | UTFWarning LineNo String
        deriving (PWarning -> PWarning -> Bool
(PWarning -> PWarning -> Bool)
-> (PWarning -> PWarning -> Bool) -> Eq PWarning
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PWarning -> PWarning -> Bool
$c/= :: PWarning -> PWarning -> Bool
== :: PWarning -> PWarning -> Bool
$c== :: PWarning -> PWarning -> Bool
Eq, Int -> PWarning -> ShowS
[PWarning] -> ShowS
PWarning -> String
(Int -> PWarning -> ShowS)
-> (PWarning -> String) -> ([PWarning] -> ShowS) -> Show PWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PWarning] -> ShowS
$cshowList :: [PWarning] -> ShowS
show :: PWarning -> String
$cshow :: PWarning -> String
showsPrec :: Int -> PWarning -> ShowS
$cshowsPrec :: Int -> PWarning -> ShowS
Show)

showPWarning :: FilePath -> PWarning -> String
showPWarning :: String -> PWarning -> String
showPWarning String
fpath (PWarning String
msg) =
  ShowS
normalise String
fpath String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
showPWarning String
fpath (UTFWarning Int
line String
fname) =
  ShowS
normalise String
fpath String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": Invalid UTF-8 text in the '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' field."

data ParseResult a = ParseFailed PError | ParseOk [PWarning] a
        deriving Int -> ParseResult a -> ShowS
[ParseResult a] -> ShowS
ParseResult a -> String
(Int -> ParseResult a -> ShowS)
-> (ParseResult a -> String)
-> ([ParseResult a] -> ShowS)
-> Show (ParseResult a)
forall a. Show a => Int -> ParseResult a -> ShowS
forall a. Show a => [ParseResult a] -> ShowS
forall a. Show a => ParseResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseResult a] -> ShowS
$cshowList :: forall a. Show a => [ParseResult a] -> ShowS
show :: ParseResult a -> String
$cshow :: forall a. Show a => ParseResult a -> String
showsPrec :: Int -> ParseResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ParseResult a -> ShowS
Show

instance Functor ParseResult where
        fmap :: (a -> b) -> ParseResult a -> ParseResult b
fmap a -> b
_ (ParseFailed PError
err) = PError -> ParseResult b
forall a. PError -> ParseResult a
ParseFailed PError
err
        fmap a -> b
f (ParseOk [PWarning]
ws a
x) = [PWarning] -> b -> ParseResult b
forall a. [PWarning] -> a -> ParseResult a
ParseOk [PWarning]
ws (b -> ParseResult b) -> b -> ParseResult b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x

instance Applicative ParseResult where
        pure :: a -> ParseResult a
pure = [PWarning] -> a -> ParseResult a
forall a. [PWarning] -> a -> ParseResult a
ParseOk []
        <*> :: ParseResult (a -> b) -> ParseResult a -> ParseResult b
(<*>) = ParseResult (a -> b) -> ParseResult a -> ParseResult b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap


instance Monad ParseResult where
        return :: a -> ParseResult a
return = a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ParseFailed PError
err >>= :: ParseResult a -> (a -> ParseResult b) -> ParseResult b
>>= a -> ParseResult b
_ = PError -> ParseResult b
forall a. PError -> ParseResult a
ParseFailed PError
err
        ParseOk [PWarning]
ws a
x >>= a -> ParseResult b
f = case a -> ParseResult b
f a
x of
                               ParseFailed PError
err -> PError -> ParseResult b
forall a. PError -> ParseResult a
ParseFailed PError
err
                               ParseOk [PWarning]
ws' b
x' -> [PWarning] -> b -> ParseResult b
forall a. [PWarning] -> a -> ParseResult a
ParseOk ([PWarning]
ws'[PWarning] -> [PWarning] -> [PWarning]
forall a. [a] -> [a] -> [a]
++[PWarning]
ws) b
x'

#if !(MIN_VERSION_base(4,9,0))
        fail = parseResultFail
#elif !(MIN_VERSION_base(4,13,0))
        fail = Fail.fail
#endif

instance Fail.MonadFail ParseResult where
        fail :: String -> ParseResult a
fail = String -> ParseResult a
forall a. String -> ParseResult a
parseResultFail

parseResultFail :: String -> ParseResult a
parseResultFail :: String -> ParseResult a
parseResultFail String
s = PError -> ParseResult a
forall a. PError -> ParseResult a
parseFail (String -> Maybe Int -> PError
FromString String
s Maybe Int
forall a. Maybe a
Nothing)

parseFail :: PError -> ParseResult a
parseFail :: PError -> ParseResult a
parseFail = PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed

runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a
runP :: Int -> String -> ReadP a a -> String -> ParseResult a
runP Int
line String
fieldname ReadP a a
p String
s =
  case [ a
x | (a
x,String
"") <- [(a, String)]
results ] of
    [a
a] -> [PWarning] -> a -> ParseResult a
forall a. [PWarning] -> a -> ParseResult a
ParseOk (Int -> String -> String -> [PWarning]
utf8Warnings Int
line String
fieldname String
s) a
a
    --TODO: what is this double parse thing all about?
    --      Can't we just do the all isSpace test the first time?
    []  -> case [ a
x | (a
x,String
ys) <- [(a, String)]
results, (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
ys ] of
             [a
a] -> [PWarning] -> a -> ParseResult a
forall a. [PWarning] -> a -> ParseResult a
ParseOk (Int -> String -> String -> [PWarning]
utf8Warnings Int
line String
fieldname String
s) a
a
             []  -> PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (String -> Int -> PError
NoParse String
fieldname Int
line)
             [a]
_   -> PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (String -> Int -> PError
AmbiguousParse String
fieldname Int
line)
    [a]
_   -> PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (String -> Int -> PError
AmbiguousParse String
fieldname Int
line)
  where results :: [(a, String)]
results = ReadP a a -> ReadS a
forall a. ReadP a a -> ReadS a
readP_to_S ReadP a a
p String
s

runE :: LineNo -> String -> ReadE a -> String -> ParseResult a
runE :: Int -> String -> ReadE a -> String -> ParseResult a
runE Int
line String
fieldname ReadE a
p String
s =
    case ReadE a -> String -> Either String a
forall a. ReadE a -> String -> Either String a
runReadE ReadE a
p String
s of
      Right a
a -> [PWarning] -> a -> ParseResult a
forall a. [PWarning] -> a -> ParseResult a
ParseOk (Int -> String -> String -> [PWarning]
utf8Warnings Int
line String
fieldname String
s) a
a
      Left  String
e -> Int -> String -> ParseResult a
forall a. Int -> String -> ParseResult a
syntaxError Int
line (String -> ParseResult a) -> String -> ParseResult a
forall a b. (a -> b) -> a -> b
$
        String
"Parse of field '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fieldname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' failed (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

utf8Warnings :: LineNo -> String -> String -> [PWarning]
utf8Warnings :: Int -> String -> String -> [PWarning]
utf8Warnings Int
line String
fieldname String
s =
  Int -> [PWarning] -> [PWarning]
forall a. Int -> [a] -> [a]
take Int
1 [ Int -> String -> PWarning
UTFWarning Int
n String
fieldname
         | (Int
n,String
l) <- [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
line..] (String -> [String]
lines String
s)
         , Char
'\xfffd' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
l ]

locatedErrorMsg :: PError -> (Maybe LineNo, String)
locatedErrorMsg :: PError -> (Maybe Int, String)
locatedErrorMsg (AmbiguousParse String
f Int
n) = (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n,
                                        String
"Ambiguous parse in field '"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
fString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"'.")
locatedErrorMsg (NoParse String
f Int
n)        = (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n,
                                        String
"Parse of field '"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
fString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"' failed.")
locatedErrorMsg (TabsError Int
n)        = (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n, String
"Tab used as indentation.")
locatedErrorMsg (FromString String
s Maybe Int
n)     = (Maybe Int
n, String
s)

syntaxError :: LineNo -> String -> ParseResult a
syntaxError :: Int -> String -> ParseResult a
syntaxError Int
n String
s = PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (PError -> ParseResult a) -> PError -> ParseResult a
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int -> PError
FromString String
s (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n)

tabsError :: LineNo -> ParseResult a
tabsError :: Int -> ParseResult a
tabsError Int
ln = PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (PError -> ParseResult a) -> PError -> ParseResult a
forall a b. (a -> b) -> a -> b
$ Int -> PError
TabsError Int
ln

warning :: String -> ParseResult ()
warning :: String -> ParseResult ()
warning String
s = [PWarning] -> () -> ParseResult ()
forall a. [PWarning] -> a -> ParseResult a
ParseOk [String -> PWarning
PWarning String
s] ()

-- | Field descriptor.  The parameter @a@ parameterizes over where the field's
--   value is stored in.
data FieldDescr a
  = FieldDescr
      { FieldDescr a -> String
fieldName     :: String
      , FieldDescr a -> a -> Doc
fieldGet      :: a -> Doc
      , FieldDescr a -> Int -> String -> a -> ParseResult a
fieldSet      :: LineNo -> String -> a -> ParseResult a
        -- ^ @fieldSet n str x@ Parses the field value from the given input
        -- string @str@ and stores the result in @x@ if the parse was
        -- successful.  Otherwise, reports an error on line number @n@.
      }

field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field String
name a -> Doc
showF ReadP a a
readF =
  String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
forall a.
String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr String
name a -> Doc
showF (\Int
line String
val a
_st -> Int -> String -> ReadP a a -> String -> ParseResult a
forall a. Int -> String -> ReadP a a -> String -> ParseResult a
runP Int
line String
name ReadP a a
readF String
val)

fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec String
name a -> Doc
showF ParsecParser a
readF =
  String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
forall a.
String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr String
name a -> Doc
showF ((Int -> String -> a -> ParseResult a) -> FieldDescr a)
-> (Int -> String -> a -> ParseResult a) -> FieldDescr a
forall a b. (a -> b) -> a -> b
$ \Int
line String
val a
_st -> case ParsecParser a -> String -> Either String a
forall a. ParsecParser a -> String -> Either String a
explicitEitherParsec ParsecParser a
readF String
val of
    Left String
err -> PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (String -> Maybe Int -> PError
FromString String
err (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
line))
    Right a
x  -> [PWarning] -> a -> ParseResult a
forall a. [PWarning] -> a -> ParseResult a
ParseOk [] a
x

-- Lift a field descriptor storing into an 'a' to a field descriptor storing
-- into a 'b'.
liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> a
get a -> b -> b
set (FieldDescr String
name a -> Doc
showF Int -> String -> a -> ParseResult a
parseF)
 = String
-> (b -> Doc)
-> (Int -> String -> b -> ParseResult b)
-> FieldDescr b
forall a.
String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr String
name (a -> Doc
showF (a -> Doc) -> (b -> a) -> b -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
get)
        (\Int
line String
str b
b -> do
            a
a <- Int -> String -> a -> ParseResult a
parseF Int
line String
str (b -> a
get b
b)
            b -> ParseResult b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b -> b
set a
a b
b))

-- Parser combinator for simple fields.  Takes a field name, a pretty printer,
-- a parser function, an accessor, and a setter, returns a FieldDescr over the
-- compoid structure.
simpleField :: String -> (a -> Doc) -> ReadP a a
            -> (b -> a) -> (a -> b -> b) -> FieldDescr b
simpleField :: String
-> (a -> Doc)
-> ReadP a a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleField String
name a -> Doc
showF ReadP a a
readF b -> a
get a -> b -> b
set
  = (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> a
get a -> b -> b
set (FieldDescr a -> FieldDescr b) -> FieldDescr a -> FieldDescr b
forall a b. (a -> b) -> a -> b
$ String -> (a -> Doc) -> ReadP a a -> FieldDescr a
forall a. String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field String
name a -> Doc
showF ReadP a a
readF

simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a
            -> (b -> a) -> (a -> b -> b) -> FieldDescr b
simpleFieldParsec :: String
-> (a -> Doc)
-> ParsecParser a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleFieldParsec String
name a -> Doc
showF ParsecParser a
readF b -> a
get a -> b -> b
set
  = (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> a
get a -> b -> b
set (FieldDescr a -> FieldDescr b) -> FieldDescr a -> FieldDescr b
forall a b. (a -> b) -> a -> b
$ String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
forall a. String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec String
name a -> Doc
showF ParsecParser a
readF

commaListFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a
                      -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListFieldWithSepParsec :: Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldWithSepParsec Separator
separator String
name a -> Doc
showF ParsecParser a
readF b -> [a]
get [a] -> b -> b
set =
   (b -> [a]) -> ([a] -> b -> b) -> FieldDescr [a] -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' (FieldDescr [a] -> FieldDescr b) -> FieldDescr [a] -> FieldDescr b
forall a b. (a -> b) -> a -> b
$
     String -> ([a] -> Doc) -> ParsecParser [a] -> FieldDescr [a]
forall a. String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec String
name [a] -> Doc
showF' (ParsecParser a -> ParsecParser [a]
forall (m :: * -> *) a. CabalParsing m => m a -> m [a]
parsecLeadingCommaList ParsecParser a
readF)
   where
     set' :: [a] -> b -> b
set' [a]
xs b
b = [a] -> b -> b
set (b -> [a]
get b
b [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
     showF' :: [a] -> Doc
showF'    = Separator
separator Separator -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([a] -> [Doc]) -> [a] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
showF

commaListFieldParsec :: String -> (a -> Doc) -> ParsecParser a
                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListFieldParsec :: String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldParsec = Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
forall a b.
Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldWithSepParsec Separator
fsep

commaNewLineListFieldParsec
    :: String -> (a -> Doc) ->  ParsecParser a
    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaNewLineListFieldParsec :: String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaNewLineListFieldParsec = Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
forall a b.
Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldWithSepParsec Separator
sep

spaceListField :: String -> (a -> Doc) -> ReadP [a] a
                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
spaceListField :: String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
spaceListField String
name a -> Doc
showF ReadP [a] a
readF b -> [a]
get [a] -> b -> b
set =
  (b -> [a]) -> ([a] -> b -> b) -> FieldDescr [a] -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' (FieldDescr [a] -> FieldDescr b) -> FieldDescr [a] -> FieldDescr b
forall a b. (a -> b) -> a -> b
$
    String -> ([a] -> Doc) -> ReadP [a] [a] -> FieldDescr [a]
forall a. String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field String
name [a] -> Doc
showF' (ReadP [a] a -> ReadP [a] [a]
forall r a. ReadP r a -> ReadP r [a]
parseSpaceList ReadP [a] a
readF)
  where
    set' :: [a] -> b -> b
set' [a]
xs b
b = [a] -> b -> b
set (b -> [a]
get b
b [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
    showF' :: [a] -> Doc
showF'    = Separator
fsep Separator -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
showF

-- this is a different definition from listField, like
-- commaNewLineListField it pretty prints on multiple lines
newLineListField :: String -> (a -> Doc) -> ReadP [a] a
                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
newLineListField :: String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
newLineListField = Separator
-> String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
forall a b.
Separator
-> String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldWithSep Separator
sep

listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a
                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listFieldWithSep :: Separator
-> String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldWithSep Separator
separator String
name a -> Doc
showF ReadP [a] a
readF b -> [a]
get [a] -> b -> b
set =
  (b -> [a]) -> ([a] -> b -> b) -> FieldDescr [a] -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' (FieldDescr [a] -> FieldDescr b) -> FieldDescr [a] -> FieldDescr b
forall a b. (a -> b) -> a -> b
$
    String -> ([a] -> Doc) -> ReadP [a] [a] -> FieldDescr [a]
forall a. String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field String
name [a] -> Doc
showF' (ReadP [a] a -> ReadP [a] [a]
forall r a. ReadP r a -> ReadP r [a]
parseOptCommaList ReadP [a] a
readF)
  where
    set' :: [a] -> b -> b
set' [a]
xs b
b = [a] -> b -> b
set (b -> [a]
get b
b [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
    showF' :: [a] -> Doc
showF'    = Separator
separator Separator -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
showF

listFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a
                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listFieldWithSepParsec :: Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldWithSepParsec Separator
separator String
name a -> Doc
showF ParsecParser a
readF b -> [a]
get [a] -> b -> b
set =
  (b -> [a]) -> ([a] -> b -> b) -> FieldDescr [a] -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' (FieldDescr [a] -> FieldDescr b) -> FieldDescr [a] -> FieldDescr b
forall a b. (a -> b) -> a -> b
$
    String -> ([a] -> Doc) -> ParsecParser [a] -> FieldDescr [a]
forall a. String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec String
name [a] -> Doc
showF' (ParsecParser a -> ParsecParser [a]
forall (m :: * -> *) a. CabalParsing m => m a -> m [a]
parsecLeadingOptCommaList ParsecParser a
readF)
  where
    set' :: [a] -> b -> b
set' [a]
xs b
b = [a] -> b -> b
set (b -> [a]
get b
b [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
    showF' :: [a] -> Doc
showF'    = Separator
separator Separator -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
showF

listField :: String -> (a -> Doc) -> ReadP [a] a
          -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listField :: String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listField = Separator
-> String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
forall a b.
Separator
-> String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldWithSep Separator
fsep

listFieldParsec
    :: String -> (a -> Doc) -> ParsecParser a
    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listFieldParsec :: String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldParsec = Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
forall a b.
Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldWithSepParsec Separator
fsep

-- | The type of a function which, given a name-value pair of an
--   unrecognized field, and the current structure being built,
--   decides whether to incorporate the unrecognized field
--   (by returning  Just x, where x is a possibly modified version
--   of the structure being built), or not (by returning Nothing).
type UnrecFieldParser a = (String,String) -> a -> Maybe a

------------------------------------------------------------------------------

-- The data type for our three syntactic categories
data Field
    = F LineNo String String
      -- ^ A regular @<property>: <value>@ field
    | Section LineNo String String [Field]
      -- ^ A section with a name and possible parameter.  The syntactic
      -- structure is:
      --
      -- @
      --   <sectionname> <arg> {
      --     <field>*
      --   }
      -- @
    | IfBlock LineNo String [Field] [Field]
      -- ^ A conditional block with an optional else branch:
      --
      -- @
      --  if <condition> {
      --    <field>*
      --  } else {
      --    <field>*
      --  }
      -- @
      deriving (Int -> Field -> ShowS
[Field] -> ShowS
Field -> String
(Int -> Field -> ShowS)
-> (Field -> String) -> ([Field] -> ShowS) -> Show Field
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Field] -> ShowS
$cshowList :: [Field] -> ShowS
show :: Field -> String
$cshow :: Field -> String
showsPrec :: Int -> Field -> ShowS
$cshowsPrec :: Int -> Field -> ShowS
Show
               ,Field -> Field -> Bool
(Field -> Field -> Bool) -> (Field -> Field -> Bool) -> Eq Field
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Field -> Field -> Bool
$c/= :: Field -> Field -> Bool
== :: Field -> Field -> Bool
$c== :: Field -> Field -> Bool
Eq)   -- for testing

lineNo :: Field -> LineNo
lineNo :: Field -> Int
lineNo (F Int
n String
_ String
_) = Int
n
lineNo (Section Int
n String
_ String
_ [Field]
_) = Int
n
lineNo (IfBlock Int
n String
_ [Field]
_ [Field]
_) = Int
n

readFields :: String -> ParseResult [Field]
readFields :: String -> ParseResult [Field]
readFields String
input = [Field] -> ParseResult [Field]
ifelse
               ([Field] -> ParseResult [Field])
-> ParseResult [Field] -> ParseResult [Field]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (SyntaxTree -> ParseResult Field)
-> [SyntaxTree] -> ParseResult [Field]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int -> SyntaxTree -> ParseResult Field
mkField Int
0)
               ([SyntaxTree] -> ParseResult [Field])
-> ParseResult [SyntaxTree] -> ParseResult [Field]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Token] -> ParseResult [SyntaxTree]
mkTree [Token]
tokens

  where ls :: [String]
ls = (String -> [String]
lines (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normaliseLineEndings) String
input
        tokens :: [Token]
tokens = (((Int, Int, Bool, String) -> [Token])
-> [(Int, Int, Bool, String)] -> [Token]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, Int, Bool, String) -> [Token]
tokeniseLine ([(Int, Int, Bool, String)] -> [Token])
-> ([String] -> [(Int, Int, Bool, String)]) -> [String] -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [(Int, Int, Bool, String)]
trimLines) [String]
ls

readFieldsFlat :: String -> ParseResult [Field]
readFieldsFlat :: String -> ParseResult [Field]
readFieldsFlat String
input = (SyntaxTree -> ParseResult Field)
-> [SyntaxTree] -> ParseResult [Field]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int -> SyntaxTree -> ParseResult Field
mkField Int
0)
                   ([SyntaxTree] -> ParseResult [Field])
-> ParseResult [SyntaxTree] -> ParseResult [Field]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Token] -> ParseResult [SyntaxTree]
mkTree [Token]
tokens
  where ls :: [String]
ls = (String -> [String]
lines (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normaliseLineEndings) String
input
        tokens :: [Token]
tokens = (((Int, Int, Bool, String) -> [Token])
-> [(Int, Int, Bool, String)] -> [Token]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, Int, Bool, String) -> [Token]
tokeniseLineFlat ([(Int, Int, Bool, String)] -> [Token])
-> ([String] -> [(Int, Int, Bool, String)]) -> [String] -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [(Int, Int, Bool, String)]
trimLines) [String]
ls

-- attach line number and determine indentation
trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)]
trimLines :: [String] -> [(Int, Int, Bool, String)]
trimLines [String]
ls = [ (Int
lineno, Int
indent, Bool
hastabs, ShowS
trimTrailing String
l')
               | (Int
lineno, String
l) <- [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [String]
ls
               , let (String
sps, String
l') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSpace String
l
                     indent :: Int
indent    = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sps
                     hastabs :: Bool
hastabs   = Char
'\t' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
sps
               , String -> Bool
validLine String
l' ]
  where validLine :: String -> Bool
validLine (Char
'-':Char
'-':String
_) = Bool
False      -- Comment
        validLine []          = Bool
False      -- blank line
        validLine String
_           = Bool
True

-- | We parse generically based on indent level and braces '{' '}'. To do that
-- we split into lines and then '{' '}' tokens and other spans within a line.
data Token =
       -- | The 'Line' token is for bits that /start/ a line, eg:
       --
       -- > "\n  blah blah { blah"
       --
       -- tokenises to:
       --
       -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"]
       --
       -- so lines are the only ones that can have nested layout, since they
       -- have a known indentation level.
       --
       -- eg: we can't have this:
       --
       -- > if ... {
       -- > } else
       -- >     other
       --
       -- because other cannot nest under else, since else doesn't start a line
       -- so cannot have nested layout. It'd have to be:
       --
       -- > if ... {
       -- > }
       -- >   else
       -- >     other
       --
       -- but that's not so common, people would normally use layout or
       -- brackets not both in a single @if else@ construct.
       --
       -- > if ... { foo : bar }
       -- > else
       -- >    other
       --
       -- this is OK
       Line LineNo Indent HasTabs String
     | Span LineNo                String  -- ^ span in a line, following brackets
     | OpenBracket LineNo | CloseBracket LineNo

type Indent = Int
type HasTabs = Bool

-- | Tokenise a single line, splitting on '{' '}' and the spans in between.
-- Also trims leading & trailing space on those spans within the line.
tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token]
tokeniseLine :: (Int, Int, Bool, String) -> [Token]
tokeniseLine (Int
n0, Int
i, Bool
t, String
l) = case Int -> String -> [Token]
split Int
n0 String
l of
                            (Span Int
_ String
l':[Token]
ss) -> Int -> Int -> Bool -> String -> Token
Line Int
n0 Int
i Bool
t String
l' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
ss
                            [Token]
cs              -> [Token]
cs
  where split :: Int -> String -> [Token]
split Int
_ String
"" = []
        split Int
n String
s  = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'}' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{') String
s of
          (String
"", Char
'{' : String
s') ->             Int -> Token
OpenBracket  Int
n Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> String -> [Token]
split Int
n String
s'
          (String
w , Char
'{' : String
s') -> Int -> String -> [Token] -> [Token]
mkspan Int
n String
w (Int -> Token
OpenBracket  Int
n Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> String -> [Token]
split Int
n String
s')
          (String
"", Char
'}' : String
s') ->             Int -> Token
CloseBracket Int
n Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> String -> [Token]
split Int
n String
s'
          (String
w , Char
'}' : String
s') -> Int -> String -> [Token] -> [Token]
mkspan Int
n String
w (Int -> Token
CloseBracket Int
n Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> String -> [Token]
split Int
n String
s')
          (String
w ,        String
_) -> Int -> String -> [Token] -> [Token]
mkspan Int
n String
w []

        mkspan :: Int -> String -> [Token] -> [Token]
mkspan Int
n String
s [Token]
ss | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s'   =             [Token]
ss
                      | Bool
otherwise = Int -> String -> Token
Span Int
n String
s' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
ss
          where s' :: String
s' = ShowS
trimTrailing (ShowS
trimLeading String
s)

tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token]
tokeniseLineFlat :: (Int, Int, Bool, String) -> [Token]
tokeniseLineFlat (Int
n0, Int
i, Bool
t, String
l)
  | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
l'   = []
  | Bool
otherwise = [Int -> Int -> Bool -> String -> Token
Line Int
n0 Int
i Bool
t String
l']
  where
    l' :: String
l' = ShowS
trimTrailing (ShowS
trimLeading String
l)

trimLeading, trimTrailing :: String -> String
trimLeading :: ShowS
trimLeading  = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
trimTrailing :: ShowS
trimTrailing = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE Char -> Bool
isSpace


type SyntaxTree = Tree (LineNo, HasTabs, String)

-- | Parse the stream of tokens into a tree of them, based on indent \/ layout
mkTree :: [Token] -> ParseResult [SyntaxTree]
mkTree :: [Token] -> ParseResult [SyntaxTree]
mkTree [Token]
toks =
  Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
layout Int
0 [] [Token]
toks ParseResult ([SyntaxTree], [Token])
-> (([SyntaxTree], [Token]) -> ParseResult [SyntaxTree])
-> ParseResult [SyntaxTree]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \([SyntaxTree]
trees, [Token]
trailing) -> case [Token]
trailing of
    []               -> [SyntaxTree] -> ParseResult [SyntaxTree]
forall (m :: * -> *) a. Monad m => a -> m a
return [SyntaxTree]
trees
    OpenBracket  Int
n:[Token]
_ -> Int -> String -> ParseResult [SyntaxTree]
forall a. Int -> String -> ParseResult a
syntaxError Int
n String
"mismatched brackets, unexpected {"
    CloseBracket Int
n:[Token]
_ -> Int -> String -> ParseResult [SyntaxTree]
forall a. Int -> String -> ParseResult a
syntaxError Int
n String
"mismatched brackets, unexpected }"
    -- the following two should never happen:
    Span Int
n     String
l  :[Token]
_ -> Int -> String -> ParseResult [SyntaxTree]
forall a. Int -> String -> ParseResult a
syntaxError Int
n (String -> ParseResult [SyntaxTree])
-> String -> ParseResult [SyntaxTree]
forall a b. (a -> b) -> a -> b
$ String
"unexpected span: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
l
    Line Int
n Int
_ Bool
_ String
l  :[Token]
_ -> Int -> String -> ParseResult [SyntaxTree]
forall a. Int -> String -> ParseResult a
syntaxError Int
n (String -> ParseResult [SyntaxTree])
-> String -> ParseResult [SyntaxTree]
forall a b. (a -> b) -> a -> b
$ String
"unexpected line: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
l


-- | Parse the stream of tokens into a tree of them, based on indent
-- This parse state expect to be in a layout context, though possibly
-- nested within a braces context so we may still encounter closing braces.
layout :: Indent       -- ^ indent level of the parent\/previous line
       -> [SyntaxTree] -- ^ accumulating param, trees in this level
       -> [Token]      -- ^ remaining tokens
       -> ParseResult ([SyntaxTree], [Token])
                       -- ^ collected trees on this level and trailing tokens
layout :: Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
layout Int
_ [SyntaxTree]
a []                               = ([SyntaxTree], [Token]) -> ParseResult ([SyntaxTree], [Token])
forall (m :: * -> *) a. Monad m => a -> m a
return ([SyntaxTree] -> [SyntaxTree]
forall a. [a] -> [a]
reverse [SyntaxTree]
a, [])
layout Int
i [SyntaxTree]
a (s :: Token
s@(Line Int
_ Int
i' Bool
_ String
_):[Token]
ss) | Int
i' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i  = ([SyntaxTree], [Token]) -> ParseResult ([SyntaxTree], [Token])
forall (m :: * -> *) a. Monad m => a -> m a
return ([SyntaxTree] -> [SyntaxTree]
forall a. [a] -> [a]
reverse [SyntaxTree]
a, Token
sToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
ss)
layout Int
i [SyntaxTree]
a (Line Int
n Int
_ Bool
t String
l:OpenBracket Int
n':[Token]
ss) = do
    ([SyntaxTree]
sub, [Token]
ss') <- Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
braces Int
n' [] [Token]
ss
    Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
layout Int
i ((Int, Bool, String) -> [SyntaxTree] -> SyntaxTree
forall a. a -> Forest a -> Tree a
Node (Int
n,Bool
t,String
l) [SyntaxTree]
subSyntaxTree -> [SyntaxTree] -> [SyntaxTree]
forall a. a -> [a] -> [a]
:[SyntaxTree]
a) [Token]
ss'

layout Int
i [SyntaxTree]
a (Span Int
n     String
l:OpenBracket Int
n':[Token]
ss) = do
    ([SyntaxTree]
sub, [Token]
ss') <- Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
braces Int
n' [] [Token]
ss
    Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
layout Int
i ((Int, Bool, String) -> [SyntaxTree] -> SyntaxTree
forall a. a -> Forest a -> Tree a
Node (Int
n,Bool
False,String
l) [SyntaxTree]
subSyntaxTree -> [SyntaxTree] -> [SyntaxTree]
forall a. a -> [a] -> [a]
:[SyntaxTree]
a) [Token]
ss'

-- look ahead to see if following lines are more indented, giving a sub-tree
layout Int
i [SyntaxTree]
a (Line Int
n Int
i' Bool
t String
l:[Token]
ss) = do
    ([SyntaxTree], [Token])
lookahead <- Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
layout (Int
i'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [] [Token]
ss
    case ([SyntaxTree], [Token])
lookahead of
        ([], [Token]
_)   -> Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
layout Int
i ((Int, Bool, String) -> [SyntaxTree] -> SyntaxTree
forall a. a -> Forest a -> Tree a
Node (Int
n,Bool
t,String
l) [] SyntaxTree -> [SyntaxTree] -> [SyntaxTree]
forall a. a -> [a] -> [a]
:[SyntaxTree]
a) [Token]
ss
        ([SyntaxTree]
ts, [Token]
ss') -> Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
layout Int
i ((Int, Bool, String) -> [SyntaxTree] -> SyntaxTree
forall a. a -> Forest a -> Tree a
Node (Int
n,Bool
t,String
l) [SyntaxTree]
ts SyntaxTree -> [SyntaxTree] -> [SyntaxTree]
forall a. a -> [a] -> [a]
:[SyntaxTree]
a) [Token]
ss'

layout Int
_ [SyntaxTree]
_ (   OpenBracket  Int
n :[Token]
_)  = Int -> String -> ParseResult ([SyntaxTree], [Token])
forall a. Int -> String -> ParseResult a
syntaxError Int
n String
"unexpected '{'"
layout Int
_ [SyntaxTree]
a (s :: Token
s@(CloseBracket Int
_):[Token]
ss) = ([SyntaxTree], [Token]) -> ParseResult ([SyntaxTree], [Token])
forall (m :: * -> *) a. Monad m => a -> m a
return ([SyntaxTree] -> [SyntaxTree]
forall a. [a] -> [a]
reverse [SyntaxTree]
a, Token
sToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
ss)
layout Int
_ [SyntaxTree]
_ (   Span Int
n String
l       : [Token]
_) = Int -> String -> ParseResult ([SyntaxTree], [Token])
forall a. Int -> String -> ParseResult a
syntaxError Int
n (String -> ParseResult ([SyntaxTree], [Token]))
-> String -> ParseResult ([SyntaxTree], [Token])
forall a b. (a -> b) -> a -> b
$ String
"unexpected span: "
                                                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
l

-- | Parse the stream of tokens into a tree of them, based on explicit braces
-- This parse state expects to find a closing bracket.
braces :: LineNo       -- ^ line of the '{', used for error messages
       -> [SyntaxTree] -- ^ accumulating param, trees in this level
       -> [Token]      -- ^ remaining tokens
       -> ParseResult ([SyntaxTree],[Token])
                       -- ^ collected trees on this level and trailing tokens
braces :: Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
braces Int
m [SyntaxTree]
a (Line Int
n Int
_ Bool
t String
l:OpenBracket Int
n':[Token]
ss) = do
    ([SyntaxTree]
sub, [Token]
ss') <- Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
braces Int
n' [] [Token]
ss
    Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
braces Int
m ((Int, Bool, String) -> [SyntaxTree] -> SyntaxTree
forall a. a -> Forest a -> Tree a
Node (Int
n,Bool
t,String
l) [SyntaxTree]
subSyntaxTree -> [SyntaxTree] -> [SyntaxTree]
forall a. a -> [a] -> [a]
:[SyntaxTree]
a) [Token]
ss'

braces Int
m [SyntaxTree]
a (Span Int
n     String
l:OpenBracket Int
n':[Token]
ss) = do
    ([SyntaxTree]
sub, [Token]
ss') <- Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
braces Int
n' [] [Token]
ss
    Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
braces Int
m ((Int, Bool, String) -> [SyntaxTree] -> SyntaxTree
forall a. a -> Forest a -> Tree a
Node (Int
n,Bool
False,String
l) [SyntaxTree]
subSyntaxTree -> [SyntaxTree] -> [SyntaxTree]
forall a. a -> [a] -> [a]
:[SyntaxTree]
a) [Token]
ss'

braces Int
m [SyntaxTree]
a (Line Int
n Int
i Bool
t String
l:[Token]
ss) = do
    ([SyntaxTree], [Token])
lookahead <- Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
layout (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [] [Token]
ss
    case ([SyntaxTree], [Token])
lookahead of
        ([], [Token]
_)   -> Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
braces Int
m ((Int, Bool, String) -> [SyntaxTree] -> SyntaxTree
forall a. a -> Forest a -> Tree a
Node (Int
n,Bool
t,String
l) [] SyntaxTree -> [SyntaxTree] -> [SyntaxTree]
forall a. a -> [a] -> [a]
:[SyntaxTree]
a) [Token]
ss
        ([SyntaxTree]
ts, [Token]
ss') -> Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
braces Int
m ((Int, Bool, String) -> [SyntaxTree] -> SyntaxTree
forall a. a -> Forest a -> Tree a
Node (Int
n,Bool
t,String
l) [SyntaxTree]
ts SyntaxTree -> [SyntaxTree] -> [SyntaxTree]
forall a. a -> [a] -> [a]
:[SyntaxTree]
a) [Token]
ss'

braces Int
m [SyntaxTree]
a (Span Int
n       String
l:[Token]
ss) = Int
-> [SyntaxTree] -> [Token] -> ParseResult ([SyntaxTree], [Token])
braces Int
m ((Int, Bool, String) -> [SyntaxTree] -> SyntaxTree
forall a. a -> Forest a -> Tree a
Node (Int
n,Bool
False,String
l) []SyntaxTree -> [SyntaxTree] -> [SyntaxTree]
forall a. a -> [a] -> [a]
:[SyntaxTree]
a) [Token]
ss
braces Int
_ [SyntaxTree]
a (CloseBracket Int
_:[Token]
ss) = ([SyntaxTree], [Token]) -> ParseResult ([SyntaxTree], [Token])
forall (m :: * -> *) a. Monad m => a -> m a
return ([SyntaxTree] -> [SyntaxTree]
forall a. [a] -> [a]
reverse [SyntaxTree]
a, [Token]
ss)
braces Int
n [SyntaxTree]
_ []                  = Int -> String -> ParseResult ([SyntaxTree], [Token])
forall a. Int -> String -> ParseResult a
syntaxError Int
n (String -> ParseResult ([SyntaxTree], [Token]))
-> String -> ParseResult ([SyntaxTree], [Token])
forall a b. (a -> b) -> a -> b
$ String
"opening brace '{'"
                              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"has no matching closing brace '}'"
braces Int
_ [SyntaxTree]
_ (OpenBracket  Int
n:[Token]
_)  = Int -> String -> ParseResult ([SyntaxTree], [Token])
forall a. Int -> String -> ParseResult a
syntaxError Int
n String
"unexpected '{'"

-- | Convert the parse tree into the Field AST
-- Also check for dodgy uses of tabs in indentation.
mkField :: Int -> SyntaxTree -> ParseResult Field
mkField :: Int -> SyntaxTree -> ParseResult Field
mkField Int
d (Node (Int
n,Bool
t,String
_) [SyntaxTree]
_) | Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Bool
t = Int -> ParseResult Field
forall a. Int -> ParseResult a
tabsError Int
n
mkField Int
d (Node (Int
n,Bool
_,String
l) [SyntaxTree]
ts) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') String
l of
  ([], String
_)       -> Int -> String -> ParseResult Field
forall a. Int -> String -> ParseResult a
syntaxError Int
n (String -> ParseResult Field) -> String -> ParseResult Field
forall a b. (a -> b) -> a -> b
$ String
"unrecognised field or section: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
l
  (String
name, String
rest)  -> case ShowS
trimLeading String
rest of
    (Char
':':String
rest') -> do let followingLines :: [(Int, Bool, String)]
followingLines = (SyntaxTree -> [(Int, Bool, String)])
-> [SyntaxTree] -> [(Int, Bool, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SyntaxTree -> [(Int, Bool, String)]
forall a. Tree a -> [a]
Tree.flatten [SyntaxTree]
ts
                          tabs :: Bool
tabs = Bool -> Bool
not ([()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [()| (Int
_,Bool
True,String
_) <- [(Int, Bool, String)]
followingLines ])
                      if Bool
tabs Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
                        then Int -> ParseResult Field
forall a. Int -> ParseResult a
tabsError Int
n
                        else Field -> ParseResult Field
forall (m :: * -> *) a. Monad m => a -> m a
return (Field -> ParseResult Field) -> Field -> ParseResult Field
forall a b. (a -> b) -> a -> b
$ Int -> String -> String -> Field
F Int
n ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
name)
                                          (String -> [(Int, Bool, String)] -> String
forall a b. String -> [(a, b, String)] -> String
fieldValue String
rest' [(Int, Bool, String)]
followingLines)
    String
rest'       -> do [Field]
ts' <- (SyntaxTree -> ParseResult Field)
-> [SyntaxTree] -> ParseResult [Field]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int -> SyntaxTree -> ParseResult Field
mkField (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) [SyntaxTree]
ts
                      Field -> ParseResult Field
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String -> String -> [Field] -> Field
Section Int
n ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
name) String
rest' [Field]
ts')
 where    fieldValue :: String -> [(a, b, String)] -> String
fieldValue String
firstLine [(a, b, String)]
followingLines =
            let firstLine' :: String
firstLine' = ShowS
trimLeading String
firstLine
                followingLines' :: [String]
followingLines' = ((a, b, String) -> String) -> [(a, b, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
_,b
_,String
s) -> ShowS
stripDot String
s) [(a, b, String)]
followingLines
                allLines :: [String]
allLines | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
firstLine' =              [String]
followingLines'
                         | Bool
otherwise       = String
firstLine' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
followingLines'
             in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [String]
allLines
          stripDot :: ShowS
stripDot String
"." = String
""
          stripDot String
s   = String
s

-- | Convert if/then/else 'Section's to 'IfBlock's
ifelse :: [Field] -> ParseResult [Field]
ifelse :: [Field] -> ParseResult [Field]
ifelse [] = [Field] -> ParseResult [Field]
forall (m :: * -> *) a. Monad m => a -> m a
return []
ifelse (Section Int
n String
"if"   String
cond [Field]
thenpart
       :Section Int
_ String
"else" String
as   [Field]
elsepart:[Field]
fs)
       | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cond     = Int -> String -> ParseResult [Field]
forall a. Int -> String -> ParseResult a
syntaxError Int
n String
"'if' with missing condition"
       | [Field] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Field]
thenpart = Int -> String -> ParseResult [Field]
forall a. Int -> String -> ParseResult a
syntaxError Int
n String
"'then' branch of 'if' is empty"
       | Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
as) = Int -> String -> ParseResult [Field]
forall a. Int -> String -> ParseResult a
syntaxError Int
n String
"'else' takes no arguments"
       | [Field] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Field]
elsepart = Int -> String -> ParseResult [Field]
forall a. Int -> String -> ParseResult a
syntaxError Int
n String
"'else' branch of 'if' is empty"
       | Bool
otherwise     = do [Field]
tp  <- [Field] -> ParseResult [Field]
ifelse [Field]
thenpart
                            [Field]
ep  <- [Field] -> ParseResult [Field]
ifelse [Field]
elsepart
                            [Field]
fs' <- [Field] -> ParseResult [Field]
ifelse [Field]
fs
                            [Field] -> ParseResult [Field]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String -> [Field] -> [Field] -> Field
IfBlock Int
n String
cond [Field]
tp [Field]
epField -> [Field] -> [Field]
forall a. a -> [a] -> [a]
:[Field]
fs')
ifelse (Section Int
n String
"if"   String
cond [Field]
thenpart:[Field]
fs)
       | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cond     = Int -> String -> ParseResult [Field]
forall a. Int -> String -> ParseResult a
syntaxError Int
n String
"'if' with missing condition"
       | [Field] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Field]
thenpart = Int -> String -> ParseResult [Field]
forall a. Int -> String -> ParseResult a
syntaxError Int
n String
"'then' branch of 'if' is empty"
       | Bool
otherwise     = do [Field]
tp  <- [Field] -> ParseResult [Field]
ifelse [Field]
thenpart
                            [Field]
fs' <- [Field] -> ParseResult [Field]
ifelse [Field]
fs
                            [Field] -> ParseResult [Field]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String -> [Field] -> [Field] -> Field
IfBlock Int
n String
cond [Field]
tp []Field -> [Field] -> [Field]
forall a. a -> [a] -> [a]
:[Field]
fs')
ifelse (Section Int
n String
"else" String
_ [Field]
_:[Field]
_) = Int -> String -> ParseResult [Field]
forall a. Int -> String -> ParseResult a
syntaxError Int
n
                                  String
"stray 'else' with no preceding 'if'"
ifelse (Section Int
n String
s String
a [Field]
fs':[Field]
fs) = do [Field]
fs''  <- [Field] -> ParseResult [Field]
ifelse [Field]
fs'
                                   [Field]
fs''' <- [Field] -> ParseResult [Field]
ifelse [Field]
fs
                                   [Field] -> ParseResult [Field]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String -> String -> [Field] -> Field
Section Int
n String
s String
a [Field]
fs'' Field -> [Field] -> [Field]
forall a. a -> [a] -> [a]
: [Field]
fs''')
ifelse (Field
f:[Field]
fs) = do [Field]
fs' <- [Field] -> ParseResult [Field]
ifelse [Field]
fs
                   [Field] -> ParseResult [Field]
forall (m :: * -> *) a. Monad m => a -> m a
return (Field
f Field -> [Field] -> [Field]
forall a. a -> [a] -> [a]
: [Field]
fs')

------------------------------------------------------------------------------

parseFilePathQ :: ReadP r FilePath
parseFilePathQ :: ReadP r String
parseFilePathQ = ReadP r String
forall r. ReadP r String
parseTokenQ
  -- removed until normalise is no longer broken, was:
  --   liftM normalise parseTokenQ

-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a
-- because the "compat" version of ReadP isn't quite powerful enough.  In
-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a
-- Hence the trick above to make 'lic' polymorphic.

-- Different than the naive version. it turns out Read instance for String accepts
-- the ['a', 'b'] syntax, which we do not want. In particular it messes
-- up any token starting with [].
parseHaskellString :: ReadP r String
parseHaskellString :: ReadP r String
parseHaskellString =
  ReadS String -> ReadP r String
forall a r. ReadS a -> ReadP r a
readS_to_P (ReadS String -> ReadP r String) -> ReadS String -> ReadP r String
forall a b. (a -> b) -> a -> b
$
    ReadPrec String -> Int -> ReadS String
forall a. ReadPrec a -> Int -> ReadS a
Read.readPrec_to_S (do Read.String String
s <- ReadPrec Lexeme
Read.lexP; String -> ReadPrec String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s) Int
0

parseTokenQ :: ReadP r String
parseTokenQ :: ReadP r String
parseTokenQ = ReadP String String
forall r. ReadP r String
parseHaskellString ReadP String String -> ReadP r String -> ReadP r String
forall a r. ReadP a a -> ReadP r a -> ReadP r a
<++ (Char -> Bool) -> ReadP r String
forall r. (Char -> Bool) -> ReadP r String
munch1 (\Char
x -> Bool -> Bool
not (Char -> Bool
isSpace Char
x) Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',')

parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas
               -> ReadP r [a]
parseSpaceList :: ReadP r a -> ReadP r [a]
parseSpaceList ReadP r a
p = ReadP r a -> ReadP r () -> ReadP r [a]
forall r a sep. ReadP r a -> ReadP r sep -> ReadP r [a]
sepBy ReadP r a
p ReadP r ()
forall r. ReadP r ()
skipSpaces

-- This version avoid parse ambiguity for list element parsers
-- that have multiple valid parses of prefixes.
parseOptCommaList :: ReadP r a -> ReadP r [a]
parseOptCommaList :: ReadP r a -> ReadP r [a]
parseOptCommaList ReadP r a
p = ReadP r a -> ReadP r () -> ReadP r [a]
forall r a sep. ReadP r a -> ReadP r sep -> ReadP r [a]
sepBy ReadP r a
p ReadP r ()
forall r. ReadP r ()
localSep
  where
    -- The separator must not be empty or it introduces ambiguity
    localSep :: ReadP r ()
localSep = (ReadP r ()
forall r. ReadP r ()
skipSpaces ReadP r () -> Parser r Char Char -> Parser r Char Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser r Char Char
forall r. Char -> ReadP r Char
char Char
',' Parser r Char Char -> ReadP r () -> ReadP r ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP r ()
forall r. ReadP r ()
skipSpaces)
      ReadP r () -> ReadP r () -> ReadP r ()
forall r a. ReadP r a -> ReadP r a -> ReadP r a
+++ ((Char -> Bool) -> Parser r Char Char
forall r. (Char -> Bool) -> ReadP r Char
satisfy Char -> Bool
isSpace Parser r Char Char -> ReadP r () -> ReadP r ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP r ()
forall r. ReadP r ()
skipSpaces)

readPToMaybe :: ReadP a a -> String -> Maybe a
readPToMaybe :: ReadP a a -> String -> Maybe a
readPToMaybe ReadP a a
p String
str = [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe [ a
r | (a
r,String
s) <- ReadP a a -> ReadS a
forall a. ReadP a a -> ReadS a
readP_to_S ReadP a a
p String
str
                                     , (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s ]