Examples.hs

{-# 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 (Eq, Ord, Show)

-- | A JSON parser (modulo some differences in numeric parsing)
jsonParser :: Parser Void Json
jsonParser = stripP valP
 where
  valP =
    altP
      [ labelP "null" nullP
      , labelP "bool" boolP
      , labelP "str" strP
      , labelP "array" arrayP
      , labelP "object" objectP
      , labelP "num" numP
      ]
  boolP = JsonBool <$> (False <$ textP_ "false" <|> True <$ textP_ "true")
  numP = JsonNum <$> sciP
  nullP = JsonNull <$ textP_ "null"
  strP = JsonString <$> doubleStrP
  arrayP = JsonArray <$> betweenP (stripEndP (textP_ "[")) (textP_ "]") (sepByP (stripEndP (textP_ ",")) (stripEndP valP))
  pairP = do
    s <- doubleStrP
    stripP (textP_ ":")
    v <- valP
    pure (s, v)
  objectP = JsonObject <$> betweenP (stripEndP (textP_ "{")) (textP_ "}") (sepByP (stripEndP (textP_ ",")) (stripEndP pairP))

-- | An arithmetic expression
data Arith
  = ArithNum !Rational
  | ArithVar !Text
  | ArithNeg Arith
  | ArithMul Arith Arith
  | ArithAdd Arith Arith
  | ArithSub Arith Arith
  deriving stock (Eq, Ord, Show)

-- | A parser for arithmetic expressions
arithParser :: Parser Void Arith
arithParser = stripP rootP
 where
  identP = takeWhile1P isAlpha
  binaryP op f = fmap (uncurry f) (infixRP op (stripEndP rootP) (stripStartP rootP))
  unaryP op f = textP_ op *> fmap f rootP
  rootP =
    altP
      [ labelP "add" (binaryP "+" ArithAdd)
      , labelP "sub" (binaryP "-" ArithSub)
      , labelP "mul" (binaryP "*" ArithMul)
      , labelP "neg" (unaryP "-" ArithNeg)
      , labelP "paren" (betweenP (stripEndP (textP_ "(")) (textP_ ")") (stripEndP rootP))
      , labelP "num" (ArithNum <$> decP)
      , labelP "var" (ArithVar <$> identP)
      ]

-- | Leaves of S-expression trees
data Atom
  = AtomIdent !Text
  | AtomString !Text
  | AtomInt !Integer
  | AtomSci !Scientific
  deriving stock (Eq, Ord, Show)

-- | An S-expression
data Sexp
  = SexpAtom !Atom
  | SexpList !(Seq Sexp)
  deriving stock (Eq, Ord, Show)

-- | A parser for S-expressions
sexpParser :: Parser Void Sexp
sexpParser = stripP rootP
 where
  identP = takeWhile1P isAlpha
  atomP =
    altP
      [ labelP "ident" (AtomIdent <$> identP)
      , labelP "string" (AtomString <$> doubleStrP)
      , labelP "int" (AtomInt <$> intP)
      , labelP "sci" (AtomSci <$> sciP)
      ]
  listP = betweenP (stripEndP (textP_ "(")) (textP_ ")") (stripEndP (sepByP space1P rootP))
  rootP =
    altP
      [ labelP "atom" (SexpAtom <$> atomP)
      , labelP "list" (SexpList <$> listP)
      ]