-- My Read class, polish notation for simplicity --- inverse (retract?) of Show.

{-# LANGUAGE DeriveGeneric, DefaultSignatures, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}

module Read where

import GHC.Generics

import Control.Applicative
import Control.Monad.Trans.State.Strict
import Data.Proxy

-- First, run of the mill parser stuff.

newtype Parser a = MkParser (StateT [String] Maybe a)
  deriving (Functor, Applicative, Alternative, Monad)

runParser :: Parser a -> [String] -> Maybe a
runParser (MkParser p) ws = evalStateT p ws

broker :: Parser (Maybe String)
broker = MkParser p
  where
    p = do
        ws <- get
        case ws of
          w : wt -> put wt >> return (Just w)
          [] -> return Nothing

anyToken :: Parser String
anyToken = do
    m <- broker
    case m of
      Just w -> return w
      Nothing -> empty

eof :: Parser ()
eof = do
    m <- broker
    case m of
      Nothing -> return ()
      Just _ -> empty

satisfy :: (String -> Bool) -> Parser String
satisfy pred = do
    w <- anyToken
    if pred w then return w else empty

token :: String -> Parser String
token w = satisfy (w ==)

readsParse :: Read a => Parser a
readsParse = do
    w <- anyToken
    case reads w of
      (a, "") : _ -> return a
      _ -> empty

-- Now the actual classes and methods.

class MyRead a where
    parse :: Parser a
    default parse :: (Generic a, GParse (Rep a)) => Parser a
    parse = fmap to gparse

    myreadm :: String -> Maybe a
    myreadm s = runParser parse (words s)

    myread :: String -> a
    myread s = case myreadm s of
      Just a -> a
      Nothing -> error "myread: no parse"

class GParse f where
    gparse :: Parser (f p)

-- instance GParse V1 where

instance GParse U1 where
    gparse = return U1

instance MyRead c => GParse (K1 i c) where
    gparse = fmap K1 parse

instance (GParse f, GParse g) => GParse ((:*:) f g) where
    gparse = liftA2 (:*:) gparse gparse

instance (GParse f, GParse g) => GParse ((:+:) f g) where
    gparse = fmap L1 gparse <|> fmap R1 gparse

instance GParse f => GParse (S1 c f) where
    gparse = fmap M1 gparse

instance (Constructor c, GParse f) => GParse (C1 c f) where
    gparse = token constructor *> fmap M1 gparse
      where
        constructor = conName (M1 Proxy :: C1 c Proxy ())

instance GParse f => GParse (D1 c f) where
    gparse = fmap M1 gparse

data My = A Bool | B Int My
    deriving (Generic, Show)

instance MyRead Bool

instance MyRead Int where
    parse = readsParse

instance MyRead My

newtype N = N My
    deriving (Generic, Show)

instance MyRead N