path: root/hadrian/src/Settings/Parser.hs

{-# LANGUAGE FlexibleContexts #-}
-- | Utilities for implementing key-value settings, as described in Note [Hadrian settings]
module Settings.Parser where

import Control.Applicative
import Control.Monad.Except
import Control.Monad.State as State
import Data.Either
import Data.List

import qualified Text.Parsec as Parsec

-- * Raw parsing of @key = value@ or @key += value@ expressions

-- | A 'Key' is parsed from a dot-separated list of words.
type Key = [String]

-- | A 'Val'ue is any 'String'.
type Val = String

-- | 'Equal' when overriding the entire computation of a setting with some
--   fresh values, 'PlusEqual' when extending it.
data Op = Equal | PlusEqual
  deriving (Eq, Ord, Show)

-- | A 'KeyVal' represents an expression @foo.bar.baz [+]= v@.
data KeyVal = KeyVal Key Op Val
  deriving (Eq, Ord, Show)

-- | Pretty-print 'KeyVal's.
ppKeyVals :: [KeyVal] -> String
ppKeyVals = unlines . map ppKeyVal

-- | Pretty-print a 'KeyVal'.
ppKeyVal :: KeyVal -> String
ppKeyVal (KeyVal k op v) =
  intercalate "." k ++ " " ++ opstr ++ " " ++ v

  where opstr = case op of
          Equal     ->  "="
          PlusEqual -> "+="

-- | Remove any string that can be parsed as a 'KeyVal' from the
--   given list.
removeKVs :: [String] -> [String]
removeKVs xs = fst (partitionKVs xs)

-- | Try to parse all strings of the given list as 'KeyVal's and keep
--   only the successful parses.
parseJustKVs :: [String] -> [KeyVal]
parseJustKVs xs = snd (partitionKVs xs)

-- | Try to parse all strings from the given list as 'KeyVal's and return
--   the ones for which parsing fails in the first component of the pair,
--   and the successful parses in the second component of the pair.
partitionKVs :: [String] -> ([String], [KeyVal])
partitionKVs xs = partitionEithers $
  map (\x -> either (const $ Left x) Right $ parseKV x) xs

-- | Try to parse all strings from the input list as 'KeyVal's.
parseKVs :: [String] -> [Either Parsec.ParseError KeyVal]
parseKVs = map parseKV

-- | Try to parse the given string as a 'KeyVal'.
parseKV :: String -> Either Parsec.ParseError KeyVal
parseKV = Parsec.parse parseKeyVal "<string list>"

-- | This implements a parser that supports @key = val@, @key = "val"@,
--   @key += val@, @key += "val"@ style syntax, where there can be 0 or more
--   spaces between the key and the operator, and the operator and the value.
parseKeyVal :: Parsec.Parsec String () KeyVal
parseKeyVal = do
  k <- parseKey
  skipSpaces
  op <- parseOp
  skipSpaces
  v <- parseValue
  return (KeyVal k op v)

  where skipSpaces = Parsec.optional (Parsec.many1 (Parsec.oneOf " \t"))

-- | Parse a dot-separated list of alpha-numerical words that can contain
--   dashes, just not at the beginning.
parseKey :: Parsec.Parsec String () Key
parseKey =
  Parsec.sepBy1 (starOr $ liftA2 (:) Parsec.alphaNum $
                  Parsec.many (Parsec.alphaNum <|> Parsec.char '-')
                )
                (Parsec.char '.')

  where starOr :: Parsec.Parsec String () String -> Parsec.Parsec String () String
        starOr p = ((\x -> [x]) <$> Parsec.char '*') <|> p

-- | Parse @=@ or @+=@.
parseOp :: Parsec.Parsec String () Op
parseOp = Parsec.choice
  [ Parsec.char '=' *> pure Equal
  , Parsec.string "+=" *> pure PlusEqual
  ]

-- | Parse @some string@ or @\"some string\"@.
parseValue :: Parsec.Parsec String () Val
parseValue = Parsec.optional (Parsec.char '\"') >> Parsec.manyTill Parsec.anyChar ((Parsec.char '\"' >> pure ()) <|> Parsec.eof)

-- * Expressing settings

-- | The current key component must match the given string.
str :: Match f => String -> f ()
str = matchString

-- | Like 'str', but returns the second argument insead of @()@.
--
-- > val s a = str s *> pure a
val :: Match f => String -> a -> f a
val s a = str s *> pure a

-- | Try and match one of the given "matchers".
--
-- > oneOf [str "hello", str "hi"] -- matches "hello" or "hi"
oneOf :: Match f => [f a] -> f a
oneOf = matchOneOf

-- | Try and match one of the given strings, returning the corresponding
--   value (the @a@) when the input matches.
choose :: Match f => [(String, a)] -> f a
choose xs = oneOf $ map (uncurry val) xs

-- | Try and match one of the given strings, or @*@, and return
--   the corresponding value (@One someValue@ or @Wildcard@ respectively).
wild :: Match f => [(String, a)] -> f (Wildcard a)
wild xs = choose $ ("*", Wildcard) : map (fmap One) xs

-- * Wildcards (@*@) in settings

-- | A @'Wildcard' a@ is either 'Wildcard' or @One x@ where @x :: a@.
data Wildcard a = Wildcard | One a
  deriving (Eq, Ord, Show)

-- | Elimination rule for 'Wildcard'. The first argument is returned
--   when the input is 'Wildcard', and when it's not the second argument
--   is applied to the value wrapped behind 'One'.
wildcard :: b -> (a -> b) -> Wildcard a -> b
wildcard z f x = case x of
  Wildcard -> z
  One a    -> f a

-- * 'Match' class, to interpret settings in various ways

-- 'matchOneOf' is similar in spirit to Alternative's '<|>',
-- but we don't really have an identity ('empty').
--
-- 'matchString' on the other hand is just a handy primitive.
--
-- Selective functors may be relevant here...?

-- | Equip the 'Applicative' class with a primitive to match a known string,
--   and another to try and match a bunch of "alternatives", returning
--   the first one that succeeds.
class Applicative f => Match f where
  matchString :: String -> f ()
  matchOneOf :: [f a] -> f a

-- * 'SettingsM' interpretation

type SettingError = String

type SettingsM = StateT Key (Either SettingError)

-- | Runs the 'SettingsM' computation, returning the value at the leaf
--   when the given 'Key' matches exactly at least one setting, erroring
--   out when it is too long or just doesn't match.
runSettingsM :: Key -> SettingsM a -> Either SettingError a
runSettingsM k m = case runStateT m k of
  Left  err     -> Left err
  Right (a, []) -> return a
  Right (_, xs) -> throwError $ "suffix " ++ show xs ++ " not found in settings"

-- | Stateful manipulation of the remaining key components,
--   with errors when strings don't match.
instance Match SettingsM where
  matchString = matchStringSettingsM
  matchOneOf = matchOneOfSettingsM

matchStringSettingsM :: String -> SettingsM ()
matchStringSettingsM s = do
  ks <- State.get
  if null ks
    then throwError $ "expected " ++ show s ++ ", got nothing"
    else go (head ks)

  where go k
          | k == s = State.modify tail
          | otherwise = throwError $
              "expected " ++ show s ++ ", got " ++ show k

matchOneOfSettingsM :: [SettingsM a] -> SettingsM a
matchOneOfSettingsM acts = StateT $ \k -> do
  firstMatch $ map (($ k) . State.runStateT) acts

  where firstMatch
          :: [Either SettingError (a, Key)]
          -> Either SettingError (a, Key)
        firstMatch []              = throwError "matchOneOf: no match"
        firstMatch (Left _ : xs)   = firstMatch xs
        firstMatch (Right res : _) = return res

-- * Completion interpretation

-- | A tree with values at the leaves ('Pure'), but where we can
--   have "linear links" with strings attached.
--
--   - @'Known' s t@ nodes are used to represent matching against
--     known strings;
--   - @'Branch' ts@ nodes are used to represent matching against a list
--     of "matchers";
--   - @'Pure' a@ nodes are used to attach values at the leaves, and help
--     provide an 'Applicative' interface.
data CompletionTree a
  = Known String (CompletionTree a)
  | Branch [CompletionTree a]
  | Pure a
  deriving (Eq, Show)

-- | Traverses 'Known' and 'Branch' nodes, only applying the
--   function to values at the leaves, wrapped with 'Pure'.
instance Functor CompletionTree where
  fmap f (Known s t) = Known s (fmap f t)
  fmap f (Branch ts) = Branch (map (fmap f) ts)
  fmap f (Pure a)    = Pure (f a)

-- | 'pure' is 'Pure', '<*>' distributes the choices.
instance Applicative CompletionTree where
  pure = Pure

  Pure f <*> Pure x    = Pure (f x)
  Pure f <*> Known s t = Known s (fmap f t)
  Pure f <*> Branch xs = Branch (map (fmap f) xs)
  Known s t <*> t'  = Known s (t <*> t')
  Branch ts <*> t'  = Branch (map (<*> t') ts)

-- | 'matchString' gets mapped to 'Known', 'matchOneOf' to 'Branch'.
instance Match CompletionTree where
  matchString s = Known s (Pure ())
  matchOneOf xs = Branch xs

-- | Enumerate all the keys a completion tree represents, with the corresponding
--   leave values.
--
--   > enumerate (val "hello" 1)) -- [(1, ["hello"])]
enumerate :: CompletionTree a -> [(a, Key)]
enumerate = go []

  where go ks (Known s t) = go (s:ks) t
        go ks (Branch xs) = concatMap (go ks) xs
        go ks (Pure a) = [(a, reverse ks)]

-- | Enumerate all the valid completions for the given input (a partially-written
--   setting key).
--
--   > complete ["hel"] (val 1 "hello")
--   >   -- returns [(1, ["hello"])]
--   > complete ["foo"] (str "foo" *> oneOf [val "hello" 1, val "world" 2])
--   >   -- returns [(1, ["foo", "hello"]), (2, ["foo", "world"])]
complete :: [String] -> CompletionTree a -> [(a, Key)]
complete [] t = enumerate t
complete (k:ks) t = case t of
  Known s t'
    | k == s -> map (fmap (s:)) (complete ks t')
    | (k `isPrefixOf` s) && null ks -> map (fmap (s:)) (enumerate t')
      -- TODO: use an Either to indicate suggestions about
      -- typos somewhere in the middle (not for the final component)
      -- (e.g "You wrote stage1.ghc-bi.ghc.hs.opts but probably
      -- meant stage1.ghc-bin.ghc.hs.opts") ?
    | otherwise -> []
  Branch ts -> concatMap (complete (k:ks)) ts
  Pure a -> return (a, [])