Skip to content

Instantly share code, notes, and snippets.

@Garciat
Last active May 16, 2021 13:00
Show Gist options
  • Save Garciat/5ea9d5a66bc5db95f13ddc36e70e7c99 to your computer and use it in GitHub Desktop.
Save Garciat/5ea9d5a66bc5db95f13ddc36e70e7c99 to your computer and use it in GitHub Desktop.
{-# 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
---
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment