Unordered parser

Unordered.hs

{-# LANGUAGE UndecidableInstances #-}

import Control.Applicative (liftA2)
import Data.Dependent.Map  qualified as D
import Data.Foldable       (foldlM)
import Data.List           (permutations)
import GHC.Generics
import Text.Parsec
import Text.Parsec.Char
import Text.Parsec.String
import Type.Reflection


--------------------------------------------------------------------------------
-- solution

-- | We need to be able to parse the "leaf" elements, hence the need for
-- 'Parseable'. We use this class to bundle the 'Typeable' constraint
class Typeable a => Parseable a where
  parseType :: Parser a

-- | An alias for a heteregoeneous map. To a given @typeRep a@ we associate a
-- list of @a@.
type UnorderedResult = D.DMap TypeRep []


-- | How to parse a given @Rep@ type.
class Unordered f where
  parseUnordered :: Parser (f p)
  -- those two only make sense for :*: and S1, which is a bit inelegant
  -- collectParsers builds the list of parsers, and extract builds our result
  -- from the heterogeneous map
  collectParsers :: [Parser UnorderedResult]
  extractResult  :: UnorderedResult -> (f p, UnorderedResult)

instance Unordered c => Unordered (D1 m c) where
  parseUnordered = M1 <$> parseUnordered @c
  collectParsers = undefined
  extractResult  = undefined

instance Unordered c => Unordered (C1 m c) where
  parseUnordered = M1 <$> parseUnordered @c
  collectParsers = undefined
  extractResult  = undefined

instance (Unordered a, Unordered b) => Unordered (a :+: b) where
  parseUnordered = choice [L1 <$> parseUnordered @a, R1 <$> parseUnordered @b]
  collectParsers = undefined
  extractResult  = undefined

instance (Unordered a, Unordered b) => Unordered (a :*: b) where
  parseUnordered   = parseAll @a @b
  -- we recursively collect parsers for all selectors
  collectParsers   = collectParsers @a <> collectParsers @b
  -- we build the LHS first, and continue building the RHS with the modified map
  extractResult m1 =
    let (fa, m2) = extractResult @a m1
        (fb, m3) = extractResult @b m2
    in  (fa :*: fb, m3)

instance Parseable a => Unordered (S1 m (Rec0 a)) where
  parseUnordered = M1 . K1 <$> parseType @a
  -- we collect just one parser of type @a@
  collectParsers = pure $ mkResultParser $ parseType @a
  -- we make the assumption that the map will always contain at least one value
  -- of our type if the parse was successful, in which case we build the @S1@,
  -- and remove the value we used from the map.
  extractResult  = D.alterF (typeRep @a) \case
    Just (x:xs) -> (M1 $ K1 x, Just xs)


-- | Given a generic type, build an unordered parser.
unordered :: (Generic a, Unordered (Rep a)) => Parser a
unordered = to <$> parseUnordered

-- | When encountering a :*:, parse it in any order. We do so by collecting the
-- parsers of all the calls to :*:, then computing all permutations of such
-- parsers, and keeping the first permutation that successfully parses.
parseAll :: forall a b p. (Unordered a, Unordered b) => Parser ((a :*: b) p)
parseAll = choice $ map mkParser $ permutations $ collectParsers @(a :*: b)
  where
    mkParser :: [Parser UnorderedResult] -> Parser ((a :*: b) p)
    mkParser = fmap postProcess . try . foldlM step D.empty
    step :: UnorderedResult -> Parser UnorderedResult -> Parser UnorderedResult
    step m = fmap $ D.unionWithKey (\_ v1 v2 -> v1 <> v2) m
    postProcess :: UnorderedResult -> (a :*: b) p
    postProcess = fst . extractResult @(a :*: b)

-- | From a @Parser a@, create a parser for an 'UnorderedResult'
mkResultParser :: forall a. Typeable a => Parser a -> Parser UnorderedResult
mkResultParser = fmap $ D.singleton (typeRep @a) . pure


--------------------------------------------------------------------------------
-- examples

instance Parseable Int where
  parseType = fmap read $ many1 digit <* spaces

instance Parseable Double where
  parseType = do
    lhs <- many1 digit
    rhs <- optionMaybe $ char '.' *> many1 digit
    spaces
    pure $ read $ lhs ++ maybe "" ('.':) rhs

instance Parseable String where
  parseType = char '"' *> many parseChar <* (char '"' >> spaces)
    where
      parseChar = satisfy (`notElem` invalid)
      invalid   = "\"\\" :: String

instance Parseable Char where
  parseType = char '\'' *> parseChar <* (char '\'' >> spaces)
    where
      parseChar = satisfy (`notElem` invalid)
      invalid   = "\"'" :: String

instance {-# OVERLAPPABLE #-} (Typeable a, Generic a, Unordered (Rep a)) => Parseable a where
  parseType = unordered


run :: Parseable a => String -> Either ParseError a
run = parse parseType ""

main = do
  print $ run @(Int, String)      "42 \"foo\"" -- Right (42,"foo")
  print $ run @(String, Int)      "42 \"foo\"" -- Right ("foo",42)
  print $ run @(Int, Int)         "42 21"      -- Right (42,21)
  print $ run @(Int, Double, Int) "42.0 1 2"   -- Right (1,42.0,2)

  print $ run @((Int, Char), String) "123 'c' \"s\"" -- Right ((123,'c'),"s")
  print $ run @((Int, Char), String) "'c' 123 \"s\"" -- Right ((123,'c'),"s")
  print $ run @((Int, Char), String) "\"s\" 123 'c'" -- Right ((123,'c'),"s")
  print $ run @((Int, Char), String) "\"s\" 123 'c'" -- Right ((123,'c'),"s")
  print $ run @((Int, Char), String) "123 \"s\" 'c'" -- /!\
  print $ run @((Int, Char), String) "123 \"s\" 'c'" -- /!\