{-# LANGUAGE OverloadedStrings #-}

-- | Example parsers
module Looksee.Examples
  ( Json (..)
  , jsonParser
  , Arith (..)
  , arithParser
  , Atom (..)
  , Sexp (..)
  , sexpParser
  )
where

import Control.Applicative ((<|>))
import Data.Char (isAlpha)
import Data.Scientific (Scientific)
import Data.Sequence (Seq)
import Data.Text (Text)
import Data.Void (Void)
import Looksee (Parser, altP, betweenP, decP, doubleStrP, infixRP, intP, labelP, sciP, sepByP, space1P, stripEndP, stripP, stripStartP, takeWhile1P, textP_)

-- | A JSON value
data Json
  = JsonNull
  | JsonString !Text
  | JsonArray !(Seq Json)
  | JsonObject !(Seq (Text, Json))
  | JsonNum !Scientific
  | JsonBool !Bool
  deriving stock (Json -> Json -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Json -> Json -> Bool
$c/= :: Json -> Json -> Bool
== :: Json -> Json -> Bool
$c== :: Json -> Json -> Bool
Eq, Eq Json
Json -> Json -> Bool
Json -> Json -> Ordering
Json -> Json -> Json
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Json -> Json -> Json
$cmin :: Json -> Json -> Json
max :: Json -> Json -> Json
$cmax :: Json -> Json -> Json
>= :: Json -> Json -> Bool
$c>= :: Json -> Json -> Bool
> :: Json -> Json -> Bool
$c> :: Json -> Json -> Bool
<= :: Json -> Json -> Bool
$c<= :: Json -> Json -> Bool
< :: Json -> Json -> Bool
$c< :: Json -> Json -> Bool
compare :: Json -> Json -> Ordering
$ccompare :: Json -> Json -> Ordering
Ord, Int -> Json -> ShowS
[Json] -> ShowS
Json -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Json] -> ShowS
$cshowList :: [Json] -> ShowS
show :: Json -> String
$cshow :: Json -> String
showsPrec :: Int -> Json -> ShowS
$cshowsPrec :: Int -> Json -> ShowS
Show)

-- | A JSON parser (modulo some differences in numeric parsing)
jsonParser :: Parser Void Json
jsonParser :: Parser Void Json
jsonParser = forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripP Parser Void Json
valP
 where
  valP :: Parser Void Json
valP =
    forall (m :: * -> *) (f :: * -> *) e a.
(Monad m, Foldable f) =>
f (ParserT e m a) -> ParserT e m a
altP
      [ forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"null" forall {e}. ParserT e Identity Json
nullP
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"bool" forall {e}. ParserT e Identity Json
boolP
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"str" forall {e}. ParserT e Identity Json
strP
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"array" Parser Void Json
arrayP
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"object" Parser Void Json
objectP
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"num" forall {e}. ParserT e Identity Json
numP
      ]
  boolP :: ParserT e Identity Json
boolP = Bool -> Json
JsonBool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
"false" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
"true")
  numP :: ParserT e Identity Json
numP = Scientific -> Json
JsonNum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) e. Monad m => ParserT e m Scientific
sciP
  nullP :: ParserT e Identity Json
nullP = Json
JsonNull forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
"null"
  strP :: ParserT e Identity Json
strP = Text -> Json
JsonString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) e. Monad m => ParserT e m Text
doubleStrP
  arrayP :: Parser Void Json
arrayP = Seq Json -> Json
JsonArray forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e (m :: * -> *) x y a.
ParserT e m x -> ParserT e m y -> ParserT e m a -> ParserT e m a
betweenP (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP (forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
"[")) (forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
"]") (forall (m :: * -> *) e x a.
Monad m =>
ParserT e m x -> ParserT e m a -> ParserT e m (Seq a)
sepByP (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP (forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
",")) (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP Parser Void Json
valP))
  pairP :: ParserT Void Identity (Text, Json)
pairP = do
    Text
s <- forall (m :: * -> *) e. Monad m => ParserT e m Text
doubleStrP
    forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripP (forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
":")
    Json
v <- Parser Void Json
valP
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
s, Json
v)
  objectP :: Parser Void Json
objectP = Seq (Text, Json) -> Json
JsonObject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e (m :: * -> *) x y a.
ParserT e m x -> ParserT e m y -> ParserT e m a -> ParserT e m a
betweenP (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP (forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
"{")) (forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
"}") (forall (m :: * -> *) e x a.
Monad m =>
ParserT e m x -> ParserT e m a -> ParserT e m (Seq a)
sepByP (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP (forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
",")) (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP ParserT Void Identity (Text, Json)
pairP))

-- | An arithmetic expression
data Arith
  = ArithNum !Rational
  | ArithVar !Text
  | ArithNeg Arith
  | ArithMul Arith Arith
  | ArithAdd Arith Arith
  | ArithSub Arith Arith
  deriving stock (Arith -> Arith -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Arith -> Arith -> Bool
$c/= :: Arith -> Arith -> Bool
== :: Arith -> Arith -> Bool
$c== :: Arith -> Arith -> Bool
Eq, Eq Arith
Arith -> Arith -> Bool
Arith -> Arith -> Ordering
Arith -> Arith -> Arith
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Arith -> Arith -> Arith
$cmin :: Arith -> Arith -> Arith
max :: Arith -> Arith -> Arith
$cmax :: Arith -> Arith -> Arith
>= :: Arith -> Arith -> Bool
$c>= :: Arith -> Arith -> Bool
> :: Arith -> Arith -> Bool
$c> :: Arith -> Arith -> Bool
<= :: Arith -> Arith -> Bool
$c<= :: Arith -> Arith -> Bool
< :: Arith -> Arith -> Bool
$c< :: Arith -> Arith -> Bool
compare :: Arith -> Arith -> Ordering
$ccompare :: Arith -> Arith -> Ordering
Ord, Int -> Arith -> ShowS
[Arith] -> ShowS
Arith -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arith] -> ShowS
$cshowList :: [Arith] -> ShowS
show :: Arith -> String
$cshow :: Arith -> String
showsPrec :: Int -> Arith -> ShowS
$cshowsPrec :: Int -> Arith -> ShowS
Show)

-- | A parser for arithmetic expressions
arithParser :: Parser Void Arith
arithParser :: Parser Void Arith
arithParser = forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripP Parser Void Arith
rootP
 where
  identP :: ParserT e Identity Text
identP = forall (m :: * -> *) e.
Monad m =>
(Char -> Bool) -> ParserT e m Text
takeWhile1P Char -> Bool
isAlpha
  binaryP :: Text -> (Arith -> Arith -> Arith) -> Parser Void Arith
binaryP Text
op Arith -> Arith -> Arith
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Arith -> Arith -> Arith
f) (forall (m :: * -> *) e a b.
Monad m =>
Text -> ParserT e m a -> ParserT e m b -> ParserT e m (a, b)
infixRP Text
op (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP Parser Void Arith
rootP) (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripStartP Parser Void Arith
rootP))
  unaryP :: Text -> (Arith -> Arith) -> Parser Void Arith
unaryP Text
op Arith -> Arith
f = forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
op forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arith -> Arith
f Parser Void Arith
rootP
  rootP :: Parser Void Arith
rootP =
    forall (m :: * -> *) (f :: * -> *) e a.
(Monad m, Foldable f) =>
f (ParserT e m a) -> ParserT e m a
altP
      [ forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"add" (Text -> (Arith -> Arith -> Arith) -> Parser Void Arith
binaryP Text
"+" Arith -> Arith -> Arith
ArithAdd)
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"sub" (Text -> (Arith -> Arith -> Arith) -> Parser Void Arith
binaryP Text
"-" Arith -> Arith -> Arith
ArithSub)
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"mul" (Text -> (Arith -> Arith -> Arith) -> Parser Void Arith
binaryP Text
"*" Arith -> Arith -> Arith
ArithMul)
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"neg" (Text -> (Arith -> Arith) -> Parser Void Arith
unaryP Text
"-" Arith -> Arith
ArithNeg)
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"paren" (forall e (m :: * -> *) x y a.
ParserT e m x -> ParserT e m y -> ParserT e m a -> ParserT e m a
betweenP (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP (forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
"(")) (forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
")") (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP Parser Void Arith
rootP))
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"num" (Rational -> Arith
ArithNum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) e. Monad m => ParserT e m Rational
decP)
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"var" (Text -> Arith
ArithVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {e}. ParserT e Identity Text
identP)
      ]

-- | Leaves of S-expression trees
data Atom
  = AtomIdent !Text
  | AtomString !Text
  | AtomInt !Integer
  | AtomSci !Scientific
  deriving stock (Atom -> Atom -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Atom -> Atom -> Bool
$c/= :: Atom -> Atom -> Bool
== :: Atom -> Atom -> Bool
$c== :: Atom -> Atom -> Bool
Eq, Eq Atom
Atom -> Atom -> Bool
Atom -> Atom -> Ordering
Atom -> Atom -> Atom
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Atom -> Atom -> Atom
$cmin :: Atom -> Atom -> Atom
max :: Atom -> Atom -> Atom
$cmax :: Atom -> Atom -> Atom
>= :: Atom -> Atom -> Bool
$c>= :: Atom -> Atom -> Bool
> :: Atom -> Atom -> Bool
$c> :: Atom -> Atom -> Bool
<= :: Atom -> Atom -> Bool
$c<= :: Atom -> Atom -> Bool
< :: Atom -> Atom -> Bool
$c< :: Atom -> Atom -> Bool
compare :: Atom -> Atom -> Ordering
$ccompare :: Atom -> Atom -> Ordering
Ord, Int -> Atom -> ShowS
[Atom] -> ShowS
Atom -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Atom] -> ShowS
$cshowList :: [Atom] -> ShowS
show :: Atom -> String
$cshow :: Atom -> String
showsPrec :: Int -> Atom -> ShowS
$cshowsPrec :: Int -> Atom -> ShowS
Show)

-- | An S-expression
data Sexp
  = SexpAtom !Atom
  | SexpList !(Seq Sexp)
  deriving stock (Sexp -> Sexp -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sexp -> Sexp -> Bool
$c/= :: Sexp -> Sexp -> Bool
== :: Sexp -> Sexp -> Bool
$c== :: Sexp -> Sexp -> Bool
Eq, Eq Sexp
Sexp -> Sexp -> Bool
Sexp -> Sexp -> Ordering
Sexp -> Sexp -> Sexp
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Sexp -> Sexp -> Sexp
$cmin :: Sexp -> Sexp -> Sexp
max :: Sexp -> Sexp -> Sexp
$cmax :: Sexp -> Sexp -> Sexp
>= :: Sexp -> Sexp -> Bool
$c>= :: Sexp -> Sexp -> Bool
> :: Sexp -> Sexp -> Bool
$c> :: Sexp -> Sexp -> Bool
<= :: Sexp -> Sexp -> Bool
$c<= :: Sexp -> Sexp -> Bool
< :: Sexp -> Sexp -> Bool
$c< :: Sexp -> Sexp -> Bool
compare :: Sexp -> Sexp -> Ordering
$ccompare :: Sexp -> Sexp -> Ordering
Ord, Int -> Sexp -> ShowS
[Sexp] -> ShowS
Sexp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Sexp] -> ShowS
$cshowList :: [Sexp] -> ShowS
show :: Sexp -> String
$cshow :: Sexp -> String
showsPrec :: Int -> Sexp -> ShowS
$cshowsPrec :: Int -> Sexp -> ShowS
Show)

-- | A parser for S-expressions
sexpParser :: Parser Void Sexp
sexpParser :: Parser Void Sexp
sexpParser = forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripP Parser Void Sexp
rootP
 where
  identP :: ParserT e Identity Text
identP = forall (m :: * -> *) e.
Monad m =>
(Char -> Bool) -> ParserT e m Text
takeWhile1P Char -> Bool
isAlpha
  atomP :: ParserT Void Identity Atom
atomP =
    forall (m :: * -> *) (f :: * -> *) e a.
(Monad m, Foldable f) =>
f (ParserT e m a) -> ParserT e m a
altP
      [ forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"ident" (Text -> Atom
AtomIdent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {e}. ParserT e Identity Text
identP)
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"string" (Text -> Atom
AtomString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) e. Monad m => ParserT e m Text
doubleStrP)
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"int" (Integer -> Atom
AtomInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) e. Monad m => ParserT e m Integer
intP)
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"sci" (Scientific -> Atom
AtomSci forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) e. Monad m => ParserT e m Scientific
sciP)
      ]
  listP :: ParserT Void Identity (Seq Sexp)
listP = forall e (m :: * -> *) x y a.
ParserT e m x -> ParserT e m y -> ParserT e m a -> ParserT e m a
betweenP (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP (forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
"(")) (forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
textP_ Text
")") (forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP (forall (m :: * -> *) e x a.
Monad m =>
ParserT e m x -> ParserT e m a -> ParserT e m (Seq a)
sepByP forall (m :: * -> *) e. Monad m => ParserT e m ()
space1P Parser Void Sexp
rootP))
  rootP :: Parser Void Sexp
rootP =
    forall (m :: * -> *) (f :: * -> *) e a.
(Monad m, Foldable f) =>
f (ParserT e m a) -> ParserT e m a
altP
      [ forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"atom" (Atom -> Sexp
SexpAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT Void Identity Atom
atomP)
      , forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
labelP Label
"list" (Seq Sexp -> Sexp
SexpList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT Void Identity (Seq Sexp)
listP)
      ]