Simplify parser return types

simplify-type.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
module Parse where

import           Data.Proxy
import           Data.Text (Text)
import qualified Data.Text as T
import           Text.Megaparsec
import qualified Text.Megaparsec.Lexer as Lexer
import           Text.Megaparsec.Text

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

example :: Parser ([Double], Int)
example =
  pMany pDouble |+| pExactly "foo" |+| pInt |+| pMany (pExactly "bar")

(|+|) :: Simplify (a, b) => Parser a -> Parser b -> Parser (Simplified (a, b))
(|+|) pa pb =
  fmap simplify ((,) <$> pa <*> pb)

pInt :: Parser Int
pInt =
  fromIntegral <$> Lexer.decimal

pDouble :: Parser Double
pDouble =
  Lexer.float

pExactly :: Text -> Parser ()
pExactly txt =
  fmap (const ()) . string $ T.unpack txt

pMany :: Parser a -> Parser [a]
pMany =
  many

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

type family Simplified a where
  Simplified (a, b) = DropUnit (Simplified a, Simplified b)
  Simplified a = DropUnit a

type family DropUnit a where
  DropUnit ((), a) = a
  DropUnit (a, ()) = a
  DropUnit [()] = ()
  DropUnit a = a

class Simplify a where
  simplify :: a -> Simplified a

instance (SimplifyCase scase a, SCase a ~ scase) => Simplify a where
  simplify =
    simplifyCase (Proxy :: Proxy scase)

------------------------------------------------------------------------
-- Simplify

data SC = SC_1 | SC_Otherwise

type family SCase a where
  SCase (a, b) =
    SC_1
  SCase a =
    SC_Otherwise

class SimplifyCase (scase :: SC) a where
  simplifyCase :: Proxy scase -> a -> Simplified a

instance
  ( DropCase (DCase (Simplified a, Simplified b)) (Simplified a, Simplified b)
  , SimplifyCase (SCase a) a
  , SimplifyCase (SCase b) b
  ) => SimplifyCase SC_1 (a, b) where
  simplifyCase _ (a0, b0) =
    let
      a =
        simplifyCase (Proxy :: Proxy (SCase a)) a0

      b =
        simplifyCase (Proxy :: Proxy (SCase b)) b0
    in
      dropCase (Proxy :: Proxy (DCase (Simplified a, Simplified b))) (a, b)

instance
  ( DropCase (DCase a) a
  , Simplified a ~ DropUnit a
  ) => SimplifyCase SC_Otherwise a where
  simplifyCase _ a =
    dropCase (Proxy :: Proxy (DCase a)) a

------------------------------------------------------------------------
-- Drop Unit

data DC = DC_1 | DC_2 | DC_3 | DC_Otherwise

type family DCase a where
  DCase ((), a) =
    DC_1
  DCase (a, ()) =
    DC_2
  DCase [()] =
    DC_3
  DCase a =
    DC_Otherwise

class DropCase (dcase :: DC) a where
  dropCase :: Proxy dcase -> a -> DropUnit a

instance DropCase DC_1 ((), a) where
  dropCase _ ((), a) =
    a

instance DropCase DC_2 (a, ()) where
  dropCase _ (a, ()) =
    a

instance DropCase DC_3 [()] where
  dropCase _ _ =
    ()

instance (DropUnit a ~ a) => DropCase DC_Otherwise a where
  dropCase _ a =
    a