ParserClass.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE FunctionalDependencies #-}
module AbstractStuff where

import Control.Applicative ( Applicative(liftA2), Alternative(..) )
import Data.Char (isDigit, isSpace)
import Data.List (intercalate)
import Data.Functor ( ($>) )
import qualified Text.Parsec as Ps
import Numeric (showHex)
import Data.Foldable (asum)

---

-- TODO not really necessary?
class Applicative f  => Selective f where
  select :: f (Either a b) -> f (a -> b) -> f b

selectM :: Monad f => f (Either a b) -> f (a -> b) -> f b
selectM x y = x >>= \case Left  a -> ($a) <$> y -- execute y
                          Right b -> pure b     -- skip y

---

class Consume t f where
  tokenPrim :: (t -> Maybe a) -> f a

---

type Parser t a = forall p. ParserClass t p => p a

class (Alternative p, Selective p, Consume t p) => ParserClass t p | p -> t where

  eof :: p () -- no reasonable default implementation?

  (<?>) :: p a -> String -> p a
  (<?>) p _ = p

  ann :: String -> p a -> p a
  ann = flip (<?>)

  ---

  parserRec :: (forall g. ParserClass t g => g a -> g a) -> p a
  parserRec fp = let p = fp p in p

  ---

  option :: a -> p a -> p a
  option a pa = pa <|> pure a

  optionMaybe :: p a -> p (Maybe a)
  optionMaybe ps = option Nothing (Just <$> ps)

  optionM :: Monoid m => p m -> p m
  optionM p = option mempty p

  choice :: [p a] -> p a
  choice = asum

  sepBy :: p a -> p sep -> p [a]
  sepBy p sep = sepBy1 p sep <|> pure []

  sepBy1 :: p a -> p sep -> p [a]
  sepBy1 p sep = liftA2 (:) p (many (sep *> p))

  ---

  satisfy :: (t -> Bool) -> p t
  satisfy p = tokenPrim (\t -> if p t then Just t else Nothing)

  element :: (Eq t, Show t) => t -> p t
  element t = satisfy (t==) <?> show t

  element_ :: (Eq t, Show t) => t -> p ()
  element_ t = element t $> ()

  ---

  anyChar :: (t ~ Char) => p Char
  anyChar = satisfy (const True)

  char :: (t ~ Char) => Char -> p Char
  char = element

  spaces :: (t ~ Char) => p ()
  spaces = many (satisfy isSpace) $> ()

  digit :: (t ~ Char) => p Char
  digit = satisfy isDigit <?> "digit"

  oneOf :: (t ~ Char) => [t] -> p t
  oneOf cs = satisfy (`elem` cs)

  noneOf :: (t ~ Char) => [t] -> p t
  noneOf cs = satisfy (`notElem` cs)

  string :: (t ~ Char) => String -> p String
  string s = traverse element s <?> s

  string_ :: (t ~ Char) => String -> p ()
  string_ s = go s <?> s
    where
      go [] = pure ()
      go cs = foldr1 (*>) (map element_ cs)

---

data ParserData t a where
  -- Functor
  PMap :: (a -> b) -> ParserData t a -> ParserData t b
  -- Applicative
  PPure :: a -> ParserData t a
  PApp :: ParserData t (a -> b) -> ParserData t a -> ParserData t b
  PRApp :: ParserData t a -> ParserData t b -> ParserData t b
  PLApp :: ParserData t a -> ParserData t b -> ParserData t a
  PLiftA2 :: (a -> b -> c) -> ParserData t a -> ParserData t b -> ParserData t c
  -- Alternative
  PEmpty :: ParserData t a
  PAlt :: ParserData t a -> ParserData t a -> ParserData t a
  PSome :: ParserData t a -> ParserData t [a]
  PMany :: ParserData t a -> ParserData t [a]
  -- Selective
  PSelect :: ParserData t (Either a b) -> ParserData t (a -> b) -> ParserData t b
  -- Consume
  PTokenPrim :: (t -> Maybe a) -> ParserData t a
  -- ParserClass
  PRec :: (forall g. ParserClass t g => g a -> g a) -> ParserData t a
  PRecHole :: String -> ParserData t a
  --
  PEof :: ParserData t ()
  --
  PSatisfy :: (t -> Bool) -> ParserData t t
  PElement :: (Eq t, Show t) => t -> ParserData t t
  PElement_ :: (Eq t, Show t) => t -> ParserData t ()
  PString :: String -> ParserData Char String

instance Show t => Show (ParserData t a) where
  showsPrec i p =
    case p of
      -- Functor
      PMap _ pa -> showParen (i > app) $
        showString "fmap f " . showsPrec (app+1) pa
      -- Applicative
      PPure _ -> showParen (i > app) $
        showString "pure a"
      PApp pf pa -> showParen (i > star) $
        showsPrec star pf . showString " <*> " . showsPrec (star+1) pa
      PLiftA2 _ pa pb -> showParen (i > app) $
        showString "liftA2 f " . showsPrec (app+1) pa . showString " " . showsPrec (app+1) pb
      PRApp pa pb -> showParen (i > star) $
        showsPrec star pa . showString " *> " . showsPrec (star+1) pb
      PLApp pa pb -> showParen (i > star) $
        showsPrec star pa . showString " <* " . showsPrec (star+1) pb
      -- Alternative
      PEmpty -> showParen (i > app) $
        showString "empty"
      PAlt p1 p2 -> showParen (i > alt) $
        showsPrec alt p1 . showString " <|> " . showsPrec (alt+1) p2
      PSome pa -> showParen (i > app) $
        showString "some " . showsPrec (app+1) pa
      PMany pa -> showParen (i > app) $
        showString "many " . showsPrec (app+1) pa
      -- Selective
      PSelect pe pf -> showParen (i > app) $
        showString "select " . showsPrec (app+1) pe . showString " " . showsPrec (app+1) pf
      -- Consume
      PTokenPrim _ -> showString "tokenPrim f"
      -- ParserClass
      -- TODO keep variable counter
      PRec f     -> showString "parserRec (\\x -> " . showsPrec i (f $ PRecHole "x") . showString ")"
      PRecHole s -> showString s
      --
      PEof -> showString "eof"
      --
      PSatisfy _ -> showParen (i > app) $
        showString "satisfy f"
      PElement t -> showParen (i > app) $
        showString "element " . showsPrec (app+1) t
      PElement_ t -> showParen (i > app) $
        showString "element_ " . showsPrec (app+1) t
      PString s -> showParen (i > app) $
        showString "string " . showsPrec (app+1) s
    where
      app = 10
      star = 4 -- infixl 4 <*>, *>, <*
      alt = 3 -- infixl 3 <|>

instance Functor (ParserData t) where
  fmap = PMap

instance Applicative (ParserData t) where
  pure = PPure
  (<*>) = PApp
  liftA2 = PLiftA2
  (*>) = PRApp
  (<*) = PLApp

instance Alternative (ParserData t) where
  empty = PEmpty
  (<|>) = PAlt
  some = PSome
  many = PMany

instance Selective (ParserData t) where
  select = PSelect

instance Consume t (ParserData t) where
  tokenPrim = PTokenPrim

instance ParserClass t (ParserData t) where
  parserRec = PRec
  eof = PEof
  satisfy = PSatisfy
  element = PElement
  element_ = PElement_
  string = PString

---

class c f => Abstract1 c f where
  toClass :: f a -> (forall g. c g => g a)

  fromClass :: (forall g. c g => g a) -> f a
  fromClass = id

instance Abstract1 (ParserClass t) (ParserData t) where
  toClass = go
    where
      go :: ParserData t a -> (forall p. ParserClass t p => p a)
      go p =
        case p of
          -- Functor
          PMap f pa -> fmap f (go pa)
          -- Applicative
          PPure a -> pure a
          PApp pf pa -> go pf <*> go pa
          PLiftA2 f pa pb -> liftA2 f (go pa) (go pb)
          PRApp pa pb -> go pa *> go pb
          PLApp pa pb -> go pa <* go pb
          -- Alternative
          PEmpty -> empty
          PAlt p1 p2 -> go p1 <|> go p2
          PSome pa -> some (go pa)
          PMany pa -> many (go pa)
          -- Selective
          PSelect pe pf -> select (go pe) (go pf)
          -- Consume
          PTokenPrim f -> tokenPrim f
          -- ParserClass
          PRec f -> parserRec f
          PRecHole _ -> error "not to be used"
          --
          PEof -> eof
          --
          PSatisfy f -> satisfy f
          PElement t -> element t
          PElement_ t -> element_ t
          PString s -> string s

parserClassToData :: forall t a. (forall p. ParserClass t p => p a) -> ParserData t a
parserClassToData = fromClass @(ParserClass t)

parserDataToClass :: forall t a. ParserData t a -> (forall p. ParserClass t p => p a)
parserDataToClass = toClass @(ParserClass t)

---

instance Selective (Ps.ParsecT s u m) where
  select = selectM

instance (Ps.Stream s m t, Show t) => Consume t (Ps.ParsecT s u m) where
  tokenPrim f = Ps.tokenPrim show nextPos f
   where
     nextPos pos _ _ = pos

instance (Ps.Stream s m t, Show t) => ParserClass t (Ps.ParsecT s u m) where
  eof = Ps.eof
  (<?>) = (Ps.<?>)
  option = Ps.option
  optionMaybe = Ps.optionMaybe
  choice = Ps.choice
  sepBy = Ps.sepBy
  sepBy1 = Ps.sepBy1
  -- satisfy
  char = Ps.char
  spaces = Ps.spaces
  digit = Ps.digit
  oneOf = Ps.oneOf
  noneOf = Ps.noneOf
  string = Ps.string

dataToParsec :: (Ps.Stream s m t, Show t) => ParserData t a -> Ps.ParsecT s u m a
dataToParsec = parserDataToClass

---

data JNumber
  = JNumber
  { jnumberMain :: String
  , jnumberFrac :: String
  , jnumberExpo :: String
  }
  deriving (Show, Eq)

data JPrim
  = JPNumber JNumber
  | JPString String
  | JPBool Bool
  | JPNull
  deriving (Show, Eq)

data JSONTok
  = JTPrim JPrim
  | JTLBrace
  | JTRBrace
  | JTLSquare
  | JTRSquare
  | JTComma
  | JTColon
  deriving Eq

instance Show JSONTok where
  show = \case
    JTPrim p  ->
      case p of
        JPNumber{} -> "number"
        JPString{} -> "string"
        JPBool{}   -> "bool"
        JPNull{}   -> "null"
    JTLBrace  -> show '{'
    JTRBrace  -> show '}'
    JTLSquare -> show '['
    JTRSquare -> show ']'
    JTComma   -> show ','
    JTColon   -> show ':'

data JSON
  = JPrim JPrim
  | JArray [JSON]
  | JObject [(String, JSON)]
  deriving (Show, Eq)

parseJString :: Parser Char String
parseJString = char '"' *> characters <* char '"'
  where
    characters = many character

    character = ann "character" $
          unit
      <|> (char '\\' *> escape)

    unit = satisfy $ \c ->
      c >= '\x0020' &&
      c <= '\x10FFFF' &&
      c /= '"' &&
      c /= '\\'

    escape = choice
      [ char '"'
      , char '\\'
      , char '/'
      , char 'b' $> '\b'
      , char 'f' $> '\f'
      , char 'n' $> '\n'
      , char 'r' $> '\r'
      , char 't' $> '\t'
      , char 'u' *> hexSeq
      ]

    hexSeq = toEnum . sum <$> sequenceA [h4, h3, h2, h1]
      where
        h1 = (*0x1) <$> hex
        h2 = (*0x10) <$> hex
        h3 = (*0x100) <$> hex
        h4 = (*0x1000) <$> hex

    hex = choice
      [ char '0' $> 0
      , char '1' $> 1
      , char '2' $> 2
      , char '3' $> 3
      , char '4' $> 4
      , char '5' $> 5
      , char '6' $> 6
      , char '7' $> 7
      , char '8' $> 8
      , char '9' $> 9
      , (char 'a' <|> char 'A') $> 10
      , (char 'b' <|> char 'B') $> 11
      , (char 'c' <|> char 'C') $> 12
      , (char 'd' <|> char 'D') $> 13
      , (char 'e' <|> char 'E') $> 14
      , (char 'f' <|> char 'F') $> 15
      ]

displayJString :: String -> String
displayJString s = ['"'] ++ concatMap f s ++ ['"']
  where
    f '"'  = ['\\', '"']
    f '\\' = ['\\', '\\']
    f c | c >= '\x0020' && c <= '\x10FFFF' = [c]
    f c = showHex (fromEnum c) "\\u"

concatA :: (Traversable t, Applicative f) => t (f [a]) -> f [a]
concatA fs = concat <$> sequenceA fs

parseJNumber :: Parser Char JNumber
parseJNumber = JNumber <$> main <*> optionM frac <*> optionM expo
  where
    main = concatA [sign, string "0" <|> value]
      where
        sign  = optionM (string "-")
        value = (:) <$> oneOf ['1'..'9'] <*> many digit

    frac = char '.' *> some digit

    expo = oneOf "eE" *> concatA [sign, some digit]
      where
        sign = optionM (string "+" <|> string "-")

displayJNumber :: JNumber -> [Char]
displayJNumber (JNumber main frac expo) = main ++ showFrac frac ++ showExpo expo
  where
    showFrac = \case
      "" -> ""
      f  -> "." ++ f

    showExpo = \case
      "" -> ""
      e  -> "e" ++ e

pjtok :: Parser Char JSONTok
pjtok = choice
  [ jstring
  , jnumber
  , jbool
  , jnull
  , lbrace
  , rbrace
  , lsquare
  , rsquare
  , colon
  , comma
  ]
  where
    jstring = JTPrim . JPString <$> parseJString

    jnumber = JTPrim . JPNumber <$> parseJNumber

    jbool = JTPrim . JPBool <$> (true <|> false)
      where
        true  = string "true"  $> True
        false = string "false" $> False

    jnull = string "null" $> JTPrim JPNull

    lsquare = char '[' $> JTLSquare
    rsquare = char ']' $> JTRSquare
    lbrace = char '{' $> JTLBrace
    rbrace = char '}' $> JTRBrace
    colon  = char ':' $> JTColon
    comma  = char ',' $> JTComma

jspaces :: Parser Char ()
jspaces = many (oneOf [' ', '\t', '\r', '\n']) $> ()

pjtokens :: Parser Char [JSONTok]
pjtokens = jspaces *> many (pjtok <* jspaces)<* eof

pjson :: Parser JSONTok JSON
pjson = parserRec go <* eof
  where
    go value = jprim <|> array <|> object
      where
        jprim = ann "primitive" $ tokenPrim $ \case
          JTPrim p -> Just (JPrim p)
          _        -> Nothing

        jstring = ann "string" $ tokenPrim $ \case
          JTPrim (JPString s) -> Just s
          _                  -> Nothing

        array = lsquare *> (JArray <$> items) <* rsquare
          where
            items = value `sepBy` comma

        object = lbrace *> (JObject <$> pairs) <* rbrace
          where
            pairs = pair `sepBy` comma
            pair  = liftA2 (,) (jstring <* colon) value

        lsquare = element_ JTLSquare
        rsquare = element_ JTRSquare
        lbrace = element_ JTLBrace
        rbrace = element_ JTRBrace
        colon  = element_ JTColon
        comma  = element_ JTComma

stringify :: JSON -> String
stringify = \case
  JPrim p ->
    case p of
      JPString s -> displayJString s
      JPNumber n -> displayJNumber n
      JPBool   b -> if b then "true" else "false"
      JPNull     -> "null"
  JArray xs ->
    "[" ++ intercalate "," (map stringify xs) ++ "]"
  JObject ps ->
    let
      f (k, v) = stringify (JPrim (JPString k)) ++ ":" ++ stringify v
    in
      "{" ++ intercalate "," (map f ps) ++ "}"

---

parseJSON :: String -> Either Ps.ParseError JSON
parseJSON s = do
  ts <- Ps.runParser pjtokens () "input" s
  Ps.runParser pjson () "input" ts

---