{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE OverloadedStrings #-}

module Mello.Syntax
  ( Sym (..)
  , Atom (..)
  , AtomType (..)
  , Brace (..)
  , Doc (..)
  , SexpF (..)
  , Sexp (..)
  , SexpType (..)
  , pattern SexpAtom
  , pattern SexpList
  , pattern SexpQuote
  , pattern SexpUnquote
  , pattern SexpDoc
  )
where

import Data.Foldable (toList)
import Data.Functor.Foldable (Base, Corecursive (..), Recursive (..))
import Data.Scientific (Scientific)
import Data.Sequence (Seq (..))
import Data.String (IsString (..))
import Data.Text (Text)
import Mello.Text (Brace (..), closeBraceChar, openBraceChar)
import Prettyprinter (Pretty (..))
import Prettyprinter qualified as P

newtype Sym = Sym {Sym -> Text
unSym :: Text}
  deriving stock (Int -> Sym -> ShowS
[Sym] -> ShowS
Sym -> String
(Int -> Sym -> ShowS)
-> (Sym -> String) -> ([Sym] -> ShowS) -> Show Sym
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Sym -> ShowS
showsPrec :: Int -> Sym -> ShowS
$cshow :: Sym -> String
show :: Sym -> String
$cshowList :: [Sym] -> ShowS
showList :: [Sym] -> ShowS
Show)
  deriving newtype (Sym -> Sym -> Bool
(Sym -> Sym -> Bool) -> (Sym -> Sym -> Bool) -> Eq Sym
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Sym -> Sym -> Bool
== :: Sym -> Sym -> Bool
$c/= :: Sym -> Sym -> Bool
/= :: Sym -> Sym -> Bool
Eq, Eq Sym
Eq Sym =>
(Sym -> Sym -> Ordering)
-> (Sym -> Sym -> Bool)
-> (Sym -> Sym -> Bool)
-> (Sym -> Sym -> Bool)
-> (Sym -> Sym -> Bool)
-> (Sym -> Sym -> Sym)
-> (Sym -> Sym -> Sym)
-> Ord Sym
Sym -> Sym -> Bool
Sym -> Sym -> Ordering
Sym -> Sym -> Sym
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
$ccompare :: Sym -> Sym -> Ordering
compare :: Sym -> Sym -> Ordering
$c< :: Sym -> Sym -> Bool
< :: Sym -> Sym -> Bool
$c<= :: Sym -> Sym -> Bool
<= :: Sym -> Sym -> Bool
$c> :: Sym -> Sym -> Bool
> :: Sym -> Sym -> Bool
$c>= :: Sym -> Sym -> Bool
>= :: Sym -> Sym -> Bool
$cmax :: Sym -> Sym -> Sym
max :: Sym -> Sym -> Sym
$cmin :: Sym -> Sym -> Sym
min :: Sym -> Sym -> Sym
Ord, String -> Sym
(String -> Sym) -> IsString Sym
forall a. (String -> a) -> IsString a
$cfromString :: String -> Sym
fromString :: String -> Sym
IsString, (forall ann. Sym -> Doc ann)
-> (forall ann. [Sym] -> Doc ann) -> Pretty Sym
forall ann. [Sym] -> Doc ann
forall ann. Sym -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
$cpretty :: forall ann. Sym -> Doc ann
pretty :: forall ann. Sym -> Doc ann
$cprettyList :: forall ann. [Sym] -> Doc ann
prettyList :: forall ann. [Sym] -> Doc ann
Pretty)

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

atomNotNumErr :: a
atomNotNumErr :: forall a. a
atomNotNumErr = String -> a
forall a. HasCallStack => String -> a
error String
"Atom not num"

-- It's a sin to define an instance this partial but it's really
-- useful to have literal syntax.
instance Num Atom where
  + :: Atom -> Atom -> Atom
(+) = \case
    AtomInt Integer
x -> \case
      AtomInt Integer
y -> Integer -> Atom
AtomInt (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y)
      AtomSci Scientific
y -> Scientific -> Atom
AtomSci (Integer -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
+ Scientific
y)
      Atom
_ -> Atom
forall a. a
atomNotNumErr
    AtomSci Scientific
x -> \case
      AtomInt Integer
y -> Scientific -> Atom
AtomSci (Scientific
x Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
+ Integer -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y)
      AtomSci Scientific
y -> Scientific -> Atom
AtomSci (Scientific
x Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
+ Scientific
y)
      Atom
_ -> Atom
forall a. a
atomNotNumErr
    Atom
_ -> Atom -> Atom
forall a. a
atomNotNumErr
  * :: Atom -> Atom -> Atom
(*) = \case
    AtomInt Integer
x -> \case
      AtomInt Integer
y -> Integer -> Atom
AtomInt (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
y)
      AtomSci Scientific
y -> Scientific -> Atom
AtomSci (Integer -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
* Scientific
y)
      Atom
_ -> Atom
forall a. a
atomNotNumErr
    AtomSci Scientific
x -> \case
      AtomInt Integer
y -> Scientific -> Atom
AtomSci (Scientific
x Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
* Integer -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y)
      AtomSci Scientific
y -> Scientific -> Atom
AtomSci (Scientific
x Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
* Scientific
y)
      Atom
_ -> Atom
forall a. a
atomNotNumErr
    Atom
_ -> Atom -> Atom
forall a. a
atomNotNumErr
  negate :: Atom -> Atom
negate = \case
    AtomInt Integer
x -> Integer -> Atom
AtomInt (Integer -> Integer
forall a. Num a => a -> a
negate Integer
x)
    AtomSci Scientific
x -> Scientific -> Atom
AtomSci (Scientific -> Scientific
forall a. Num a => a -> a
negate Scientific
x)
    Atom
_ -> Atom
forall a. a
atomNotNumErr
  abs :: Atom -> Atom
abs = \case
    AtomInt Integer
x -> Integer -> Atom
AtomInt (Integer -> Integer
forall a. Num a => a -> a
abs Integer
x)
    AtomSci Scientific
x -> Scientific -> Atom
AtomSci (Scientific -> Scientific
forall a. Num a => a -> a
abs Scientific
x)
    Atom
_ -> Atom
forall a. a
atomNotNumErr
  signum :: Atom -> Atom
signum = \case
    AtomInt Integer
x -> Integer -> Atom
AtomInt (Integer -> Integer
forall a. Num a => a -> a
signum Integer
x)
    AtomSci Scientific
x -> Scientific -> Atom
AtomSci (Scientific -> Scientific
forall a. Num a => a -> a
signum Scientific
x)
    Atom
_ -> Atom
forall a. a
atomNotNumErr
  fromInteger :: Integer -> Atom
fromInteger = Integer -> Atom
AtomInt

instance IsString Atom where
  fromString :: String -> Atom
fromString = Sym -> Atom
AtomSym (Sym -> Atom) -> (String -> Sym) -> String -> Atom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Sym
forall a. IsString a => String -> a
fromString

instance Pretty Atom where
  pretty :: forall ann. Atom -> Doc ann
pretty = \case
    AtomSym Sym
x -> Sym -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Sym -> Doc ann
pretty Sym
x
    AtomInt Integer
x -> Integer -> Doc ann
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
x
    AtomSci Scientific
x -> Scientific -> Doc ann
forall a ann. Show a => a -> Doc ann
P.viaShow Scientific
x
    AtomStr Text
x -> Doc ann
"\"" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"\""
    AtomChar Char
x -> Doc ann
"'" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"'"

data AtomType
  = AtomTypeSym
  | AtomTypeInt
  | AtomTypeSci
  | AtomTypeStr
  | AtomTypeChar
  deriving stock (AtomType -> AtomType -> Bool
(AtomType -> AtomType -> Bool)
-> (AtomType -> AtomType -> Bool) -> Eq AtomType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AtomType -> AtomType -> Bool
== :: AtomType -> AtomType -> Bool
$c/= :: AtomType -> AtomType -> Bool
/= :: AtomType -> AtomType -> Bool
Eq, Eq AtomType
Eq AtomType =>
(AtomType -> AtomType -> Ordering)
-> (AtomType -> AtomType -> Bool)
-> (AtomType -> AtomType -> Bool)
-> (AtomType -> AtomType -> Bool)
-> (AtomType -> AtomType -> Bool)
-> (AtomType -> AtomType -> AtomType)
-> (AtomType -> AtomType -> AtomType)
-> Ord AtomType
AtomType -> AtomType -> Bool
AtomType -> AtomType -> Ordering
AtomType -> AtomType -> AtomType
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
$ccompare :: AtomType -> AtomType -> Ordering
compare :: AtomType -> AtomType -> Ordering
$c< :: AtomType -> AtomType -> Bool
< :: AtomType -> AtomType -> Bool
$c<= :: AtomType -> AtomType -> Bool
<= :: AtomType -> AtomType -> Bool
$c> :: AtomType -> AtomType -> Bool
> :: AtomType -> AtomType -> Bool
$c>= :: AtomType -> AtomType -> Bool
>= :: AtomType -> AtomType -> Bool
$cmax :: AtomType -> AtomType -> AtomType
max :: AtomType -> AtomType -> AtomType
$cmin :: AtomType -> AtomType -> AtomType
min :: AtomType -> AtomType -> AtomType
Ord, Int -> AtomType -> ShowS
[AtomType] -> ShowS
AtomType -> String
(Int -> AtomType -> ShowS)
-> (AtomType -> String) -> ([AtomType] -> ShowS) -> Show AtomType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AtomType -> ShowS
showsPrec :: Int -> AtomType -> ShowS
$cshow :: AtomType -> String
show :: AtomType -> String
$cshowList :: [AtomType] -> ShowS
showList :: [AtomType] -> ShowS
Show, Int -> AtomType
AtomType -> Int
AtomType -> [AtomType]
AtomType -> AtomType
AtomType -> AtomType -> [AtomType]
AtomType -> AtomType -> AtomType -> [AtomType]
(AtomType -> AtomType)
-> (AtomType -> AtomType)
-> (Int -> AtomType)
-> (AtomType -> Int)
-> (AtomType -> [AtomType])
-> (AtomType -> AtomType -> [AtomType])
-> (AtomType -> AtomType -> [AtomType])
-> (AtomType -> AtomType -> AtomType -> [AtomType])
-> Enum AtomType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: AtomType -> AtomType
succ :: AtomType -> AtomType
$cpred :: AtomType -> AtomType
pred :: AtomType -> AtomType
$ctoEnum :: Int -> AtomType
toEnum :: Int -> AtomType
$cfromEnum :: AtomType -> Int
fromEnum :: AtomType -> Int
$cenumFrom :: AtomType -> [AtomType]
enumFrom :: AtomType -> [AtomType]
$cenumFromThen :: AtomType -> AtomType -> [AtomType]
enumFromThen :: AtomType -> AtomType -> [AtomType]
$cenumFromTo :: AtomType -> AtomType -> [AtomType]
enumFromTo :: AtomType -> AtomType -> [AtomType]
$cenumFromThenTo :: AtomType -> AtomType -> AtomType -> [AtomType]
enumFromThenTo :: AtomType -> AtomType -> AtomType -> [AtomType]
Enum, AtomType
AtomType -> AtomType -> Bounded AtomType
forall a. a -> a -> Bounded a
$cminBound :: AtomType
minBound :: AtomType
$cmaxBound :: AtomType
maxBound :: AtomType
Bounded)

atomType :: Atom -> AtomType
atomType :: Atom -> AtomType
atomType = \case
  AtomSym Sym
_ -> AtomType
AtomTypeSym
  AtomInt Integer
_ -> AtomType
AtomTypeInt
  AtomSci Scientific
_ -> AtomType
AtomTypeSci
  AtomStr Text
_ -> AtomType
AtomTypeStr
  AtomChar Char
_ -> AtomType
AtomTypeChar

newtype Doc = Doc {Doc -> Seq Text
unDoc :: Seq Text}
  deriving stock (Int -> Doc -> ShowS
[Doc] -> ShowS
Doc -> String
(Int -> Doc -> ShowS)
-> (Doc -> String) -> ([Doc] -> ShowS) -> Show Doc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Doc -> ShowS
showsPrec :: Int -> Doc -> ShowS
$cshow :: Doc -> String
show :: Doc -> String
$cshowList :: [Doc] -> ShowS
showList :: [Doc] -> ShowS
Show)
  deriving newtype (Doc -> Doc -> Bool
(Doc -> Doc -> Bool) -> (Doc -> Doc -> Bool) -> Eq Doc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Doc -> Doc -> Bool
== :: Doc -> Doc -> Bool
$c/= :: Doc -> Doc -> Bool
/= :: Doc -> Doc -> Bool
Eq, Eq Doc
Eq Doc =>
(Doc -> Doc -> Ordering)
-> (Doc -> Doc -> Bool)
-> (Doc -> Doc -> Bool)
-> (Doc -> Doc -> Bool)
-> (Doc -> Doc -> Bool)
-> (Doc -> Doc -> Doc)
-> (Doc -> Doc -> Doc)
-> Ord Doc
Doc -> Doc -> Bool
Doc -> Doc -> Ordering
Doc -> Doc -> Doc
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
$ccompare :: Doc -> Doc -> Ordering
compare :: Doc -> Doc -> Ordering
$c< :: Doc -> Doc -> Bool
< :: Doc -> Doc -> Bool
$c<= :: Doc -> Doc -> Bool
<= :: Doc -> Doc -> Bool
$c> :: Doc -> Doc -> Bool
> :: Doc -> Doc -> Bool
$c>= :: Doc -> Doc -> Bool
>= :: Doc -> Doc -> Bool
$cmax :: Doc -> Doc -> Doc
max :: Doc -> Doc -> Doc
$cmin :: Doc -> Doc -> Doc
min :: Doc -> Doc -> Doc
Ord)

-- | An S-expression
data SexpF r
  = SexpAtomF !Atom
  | SexpListF !Brace !(Seq r)
  | SexpQuoteF r
  | SexpUnquoteF r
  | SexpDocF !Doc r
  deriving stock (SexpF r -> SexpF r -> Bool
(SexpF r -> SexpF r -> Bool)
-> (SexpF r -> SexpF r -> Bool) -> Eq (SexpF r)
forall r. Eq r => SexpF r -> SexpF r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall r. Eq r => SexpF r -> SexpF r -> Bool
== :: SexpF r -> SexpF r -> Bool
$c/= :: forall r. Eq r => SexpF r -> SexpF r -> Bool
/= :: SexpF r -> SexpF r -> Bool
Eq, Eq (SexpF r)
Eq (SexpF r) =>
(SexpF r -> SexpF r -> Ordering)
-> (SexpF r -> SexpF r -> Bool)
-> (SexpF r -> SexpF r -> Bool)
-> (SexpF r -> SexpF r -> Bool)
-> (SexpF r -> SexpF r -> Bool)
-> (SexpF r -> SexpF r -> SexpF r)
-> (SexpF r -> SexpF r -> SexpF r)
-> Ord (SexpF r)
SexpF r -> SexpF r -> Bool
SexpF r -> SexpF r -> Ordering
SexpF r -> SexpF r -> SexpF r
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
forall r. Ord r => Eq (SexpF r)
forall r. Ord r => SexpF r -> SexpF r -> Bool
forall r. Ord r => SexpF r -> SexpF r -> Ordering
forall r. Ord r => SexpF r -> SexpF r -> SexpF r
$ccompare :: forall r. Ord r => SexpF r -> SexpF r -> Ordering
compare :: SexpF r -> SexpF r -> Ordering
$c< :: forall r. Ord r => SexpF r -> SexpF r -> Bool
< :: SexpF r -> SexpF r -> Bool
$c<= :: forall r. Ord r => SexpF r -> SexpF r -> Bool
<= :: SexpF r -> SexpF r -> Bool
$c> :: forall r. Ord r => SexpF r -> SexpF r -> Bool
> :: SexpF r -> SexpF r -> Bool
$c>= :: forall r. Ord r => SexpF r -> SexpF r -> Bool
>= :: SexpF r -> SexpF r -> Bool
$cmax :: forall r. Ord r => SexpF r -> SexpF r -> SexpF r
max :: SexpF r -> SexpF r -> SexpF r
$cmin :: forall r. Ord r => SexpF r -> SexpF r -> SexpF r
min :: SexpF r -> SexpF r -> SexpF r
Ord, Int -> SexpF r -> ShowS
[SexpF r] -> ShowS
SexpF r -> String
(Int -> SexpF r -> ShowS)
-> (SexpF r -> String) -> ([SexpF r] -> ShowS) -> Show (SexpF r)
forall r. Show r => Int -> SexpF r -> ShowS
forall r. Show r => [SexpF r] -> ShowS
forall r. Show r => SexpF r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall r. Show r => Int -> SexpF r -> ShowS
showsPrec :: Int -> SexpF r -> ShowS
$cshow :: forall r. Show r => SexpF r -> String
show :: SexpF r -> String
$cshowList :: forall r. Show r => [SexpF r] -> ShowS
showList :: [SexpF r] -> ShowS
Show, (forall a b. (a -> b) -> SexpF a -> SexpF b)
-> (forall a b. a -> SexpF b -> SexpF a) -> Functor SexpF
forall a b. a -> SexpF b -> SexpF a
forall a b. (a -> b) -> SexpF a -> SexpF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> SexpF a -> SexpF b
fmap :: forall a b. (a -> b) -> SexpF a -> SexpF b
$c<$ :: forall a b. a -> SexpF b -> SexpF a
<$ :: forall a b. a -> SexpF b -> SexpF a
Functor, (forall m. Monoid m => SexpF m -> m)
-> (forall m a. Monoid m => (a -> m) -> SexpF a -> m)
-> (forall m a. Monoid m => (a -> m) -> SexpF a -> m)
-> (forall a b. (a -> b -> b) -> b -> SexpF a -> b)
-> (forall a b. (a -> b -> b) -> b -> SexpF a -> b)
-> (forall b a. (b -> a -> b) -> b -> SexpF a -> b)
-> (forall b a. (b -> a -> b) -> b -> SexpF a -> b)
-> (forall a. (a -> a -> a) -> SexpF a -> a)
-> (forall a. (a -> a -> a) -> SexpF a -> a)
-> (forall a. SexpF a -> [a])
-> (forall a. SexpF a -> Bool)
-> (forall a. SexpF a -> Int)
-> (forall a. Eq a => a -> SexpF a -> Bool)
-> (forall a. Ord a => SexpF a -> a)
-> (forall a. Ord a => SexpF a -> a)
-> (forall a. Num a => SexpF a -> a)
-> (forall a. Num a => SexpF a -> a)
-> Foldable SexpF
forall a. Eq a => a -> SexpF a -> Bool
forall a. Num a => SexpF a -> a
forall a. Ord a => SexpF a -> a
forall m. Monoid m => SexpF m -> m
forall a. SexpF a -> Bool
forall a. SexpF a -> Int
forall a. SexpF a -> [a]
forall a. (a -> a -> a) -> SexpF a -> a
forall m a. Monoid m => (a -> m) -> SexpF a -> m
forall b a. (b -> a -> b) -> b -> SexpF a -> b
forall a b. (a -> b -> b) -> b -> SexpF a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => SexpF m -> m
fold :: forall m. Monoid m => SexpF m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> SexpF a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> SexpF a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> SexpF a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> SexpF a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> SexpF a -> b
foldr :: forall a b. (a -> b -> b) -> b -> SexpF a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> SexpF a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> SexpF a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> SexpF a -> b
foldl :: forall b a. (b -> a -> b) -> b -> SexpF a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> SexpF a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> SexpF a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> SexpF a -> a
foldr1 :: forall a. (a -> a -> a) -> SexpF a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> SexpF a -> a
foldl1 :: forall a. (a -> a -> a) -> SexpF a -> a
$ctoList :: forall a. SexpF a -> [a]
toList :: forall a. SexpF a -> [a]
$cnull :: forall a. SexpF a -> Bool
null :: forall a. SexpF a -> Bool
$clength :: forall a. SexpF a -> Int
length :: forall a. SexpF a -> Int
$celem :: forall a. Eq a => a -> SexpF a -> Bool
elem :: forall a. Eq a => a -> SexpF a -> Bool
$cmaximum :: forall a. Ord a => SexpF a -> a
maximum :: forall a. Ord a => SexpF a -> a
$cminimum :: forall a. Ord a => SexpF a -> a
minimum :: forall a. Ord a => SexpF a -> a
$csum :: forall a. Num a => SexpF a -> a
sum :: forall a. Num a => SexpF a -> a
$cproduct :: forall a. Num a => SexpF a -> a
product :: forall a. Num a => SexpF a -> a
Foldable, Functor SexpF
Foldable SexpF
(Functor SexpF, Foldable SexpF) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> SexpF a -> f (SexpF b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    SexpF (f a) -> f (SexpF a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> SexpF a -> m (SexpF b))
-> (forall (m :: * -> *) a. Monad m => SexpF (m a) -> m (SexpF a))
-> Traversable SexpF
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => SexpF (m a) -> m (SexpF a)
forall (f :: * -> *) a. Applicative f => SexpF (f a) -> f (SexpF a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SexpF a -> m (SexpF b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SexpF a -> f (SexpF b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SexpF a -> f (SexpF b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SexpF a -> f (SexpF b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => SexpF (f a) -> f (SexpF a)
sequenceA :: forall (f :: * -> *) a. Applicative f => SexpF (f a) -> f (SexpF a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SexpF a -> m (SexpF b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SexpF a -> m (SexpF b)
$csequence :: forall (m :: * -> *) a. Monad m => SexpF (m a) -> m (SexpF a)
sequence :: forall (m :: * -> *) a. Monad m => SexpF (m a) -> m (SexpF a)
Traversable)

sexpNotNumErr :: a
sexpNotNumErr :: forall a. a
sexpNotNumErr = String -> a
forall a. HasCallStack => String -> a
error String
"Sexp not num"

-- Again, bad instance, but nice to have literal syntax
instance Num (SexpF a) where
  + :: SexpF a -> SexpF a -> SexpF a
(+) = \case
    SexpAtomF Atom
x -> \case
      SexpAtomF Atom
y -> Atom -> SexpF a
forall r. Atom -> SexpF r
SexpAtomF (Atom
x Atom -> Atom -> Atom
forall a. Num a => a -> a -> a
+ Atom
y)
      SexpF a
_ -> SexpF a
forall a. a
sexpNotNumErr
    SexpF a
_ -> SexpF a -> SexpF a
forall a. a
sexpNotNumErr
  * :: SexpF a -> SexpF a -> SexpF a
(*) = \case
    SexpAtomF Atom
x -> \case
      SexpAtomF Atom
y -> Atom -> SexpF a
forall r. Atom -> SexpF r
SexpAtomF (Atom
x Atom -> Atom -> Atom
forall a. Num a => a -> a -> a
* Atom
y)
      SexpF a
_ -> SexpF a
forall a. a
sexpNotNumErr
    SexpF a
_ -> SexpF a -> SexpF a
forall a. a
sexpNotNumErr
  negate :: SexpF a -> SexpF a
negate = \case
    SexpAtomF Atom
x -> Atom -> SexpF a
forall r. Atom -> SexpF r
SexpAtomF (Atom -> Atom
forall a. Num a => a -> a
negate Atom
x)
    SexpF a
_ -> SexpF a
forall a. a
sexpNotNumErr
  abs :: SexpF a -> SexpF a
abs = \case
    SexpAtomF Atom
x -> Atom -> SexpF a
forall r. Atom -> SexpF r
SexpAtomF (Atom -> Atom
forall a. Num a => a -> a
abs Atom
x)
    SexpF a
_ -> SexpF a
forall a. a
sexpNotNumErr
  signum :: SexpF a -> SexpF a
signum = \case
    SexpAtomF Atom
x -> Atom -> SexpF a
forall r. Atom -> SexpF r
SexpAtomF (Atom -> Atom
forall a. Num a => a -> a
signum Atom
x)
    SexpF a
_ -> SexpF a
forall a. a
sexpNotNumErr
  fromInteger :: Integer -> SexpF a
fromInteger = Atom -> SexpF a
forall r. Atom -> SexpF r
SexpAtomF (Atom -> SexpF a) -> (Integer -> Atom) -> Integer -> SexpF a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Atom
forall a. Num a => Integer -> a
fromInteger

instance IsString (SexpF r) where
  fromString :: String -> SexpF r
fromString = Atom -> SexpF r
forall r. Atom -> SexpF r
SexpAtomF (Atom -> SexpF r) -> (String -> Atom) -> String -> SexpF r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Atom
forall a. IsString a => String -> a
fromString

instance (Pretty r) => Pretty (SexpF r) where
  pretty :: forall ann. SexpF r -> Doc ann
pretty = \case
    SexpAtomF Atom
a -> Atom -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Atom -> Doc ann
pretty Atom
a
    SexpListF Brace
b Seq r
rs -> Char -> Doc ann
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Brace -> Char
openBraceChar Brace
b) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
P.hsep ((r -> Doc ann) -> [r] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Doc ann
forall ann. r -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Seq r -> [r]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq r
rs)) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Brace -> Char
closeBraceChar Brace
b)
    SexpQuoteF r
r -> Doc ann
"`" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> r -> Doc ann
forall ann. r -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty r
r
    SexpUnquoteF r
r -> Doc ann
"," Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> r -> Doc ann
forall ann. r -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty r
r
    SexpDocF (Doc Seq Text
d) r
r ->
      case Seq Text
d of
        Seq Text
Empty -> r -> Doc ann
forall ann. r -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty r
r
        Text
h :<| Seq Text
t ->
          let h' :: Doc ann
h' = (Doc ann
";|" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
h Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"\n")
              t' :: Seq (Doc ann)
t' = (Text -> Doc ann) -> Seq Text -> Seq (Doc ann)
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
x -> Doc ann
";" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"\n") Seq Text
t
          in  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
P.hcat (Seq (Doc ann) -> [Doc ann]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Doc ann
h' Doc ann -> Seq (Doc ann) -> Seq (Doc ann)
forall a. a -> Seq a -> Seq a
:<| (Seq (Doc ann)
t' Seq (Doc ann) -> Doc ann -> Seq (Doc ann)
forall a. Seq a -> a -> Seq a
:|> r -> Doc ann
forall ann. r -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty r
r)))

newtype Sexp = Sexp {Sexp -> SexpF Sexp
unSexp :: SexpF Sexp}
  deriving stock (Int -> Sexp -> ShowS
[Sexp] -> ShowS
Sexp -> String
(Int -> Sexp -> ShowS)
-> (Sexp -> String) -> ([Sexp] -> ShowS) -> Show Sexp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Sexp -> ShowS
showsPrec :: Int -> Sexp -> ShowS
$cshow :: Sexp -> String
show :: Sexp -> String
$cshowList :: [Sexp] -> ShowS
showList :: [Sexp] -> ShowS
Show)
  deriving newtype (Sexp -> Sexp -> Bool
(Sexp -> Sexp -> Bool) -> (Sexp -> Sexp -> Bool) -> Eq Sexp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Sexp -> Sexp -> Bool
== :: Sexp -> Sexp -> Bool
$c/= :: Sexp -> Sexp -> Bool
/= :: Sexp -> Sexp -> Bool
Eq, Eq Sexp
Eq Sexp =>
(Sexp -> Sexp -> Ordering)
-> (Sexp -> Sexp -> Bool)
-> (Sexp -> Sexp -> Bool)
-> (Sexp -> Sexp -> Bool)
-> (Sexp -> Sexp -> Bool)
-> (Sexp -> Sexp -> Sexp)
-> (Sexp -> Sexp -> Sexp)
-> Ord 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
$ccompare :: Sexp -> Sexp -> Ordering
compare :: Sexp -> Sexp -> Ordering
$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
>= :: Sexp -> Sexp -> Bool
$cmax :: Sexp -> Sexp -> Sexp
max :: Sexp -> Sexp -> Sexp
$cmin :: Sexp -> Sexp -> Sexp
min :: Sexp -> Sexp -> Sexp
Ord, Integer -> Sexp
Sexp -> Sexp
Sexp -> Sexp -> Sexp
(Sexp -> Sexp -> Sexp)
-> (Sexp -> Sexp -> Sexp)
-> (Sexp -> Sexp -> Sexp)
-> (Sexp -> Sexp)
-> (Sexp -> Sexp)
-> (Sexp -> Sexp)
-> (Integer -> Sexp)
-> Num Sexp
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Sexp -> Sexp -> Sexp
+ :: Sexp -> Sexp -> Sexp
$c- :: Sexp -> Sexp -> Sexp
- :: Sexp -> Sexp -> Sexp
$c* :: Sexp -> Sexp -> Sexp
* :: Sexp -> Sexp -> Sexp
$cnegate :: Sexp -> Sexp
negate :: Sexp -> Sexp
$cabs :: Sexp -> Sexp
abs :: Sexp -> Sexp
$csignum :: Sexp -> Sexp
signum :: Sexp -> Sexp
$cfromInteger :: Integer -> Sexp
fromInteger :: Integer -> Sexp
Num, String -> Sexp
(String -> Sexp) -> IsString Sexp
forall a. (String -> a) -> IsString a
$cfromString :: String -> Sexp
fromString :: String -> Sexp
IsString, (forall ann. Sexp -> Doc ann)
-> (forall ann. [Sexp] -> Doc ann) -> Pretty Sexp
forall ann. [Sexp] -> Doc ann
forall ann. Sexp -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
$cpretty :: forall ann. Sexp -> Doc ann
pretty :: forall ann. Sexp -> Doc ann
$cprettyList :: forall ann. [Sexp] -> Doc ann
prettyList :: forall ann. [Sexp] -> Doc ann
Pretty)

type instance Base Sexp = SexpF

instance Recursive Sexp where project :: Sexp -> Base Sexp Sexp
project = Sexp -> Base Sexp Sexp
Sexp -> SexpF Sexp
unSexp

instance Corecursive Sexp where embed :: Base Sexp Sexp -> Sexp
embed = Base Sexp Sexp -> Sexp
SexpF Sexp -> Sexp
Sexp

data SexpType
  = SexpTypeAtom !AtomType
  | SexpTypeList !Brace
  | SexpTypeQuote
  | SexpTypeUnquote
  | SexpTypeDoc
  deriving stock (SexpType -> SexpType -> Bool
(SexpType -> SexpType -> Bool)
-> (SexpType -> SexpType -> Bool) -> Eq SexpType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SexpType -> SexpType -> Bool
== :: SexpType -> SexpType -> Bool
$c/= :: SexpType -> SexpType -> Bool
/= :: SexpType -> SexpType -> Bool
Eq, Eq SexpType
Eq SexpType =>
(SexpType -> SexpType -> Ordering)
-> (SexpType -> SexpType -> Bool)
-> (SexpType -> SexpType -> Bool)
-> (SexpType -> SexpType -> Bool)
-> (SexpType -> SexpType -> Bool)
-> (SexpType -> SexpType -> SexpType)
-> (SexpType -> SexpType -> SexpType)
-> Ord SexpType
SexpType -> SexpType -> Bool
SexpType -> SexpType -> Ordering
SexpType -> SexpType -> SexpType
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
$ccompare :: SexpType -> SexpType -> Ordering
compare :: SexpType -> SexpType -> Ordering
$c< :: SexpType -> SexpType -> Bool
< :: SexpType -> SexpType -> Bool
$c<= :: SexpType -> SexpType -> Bool
<= :: SexpType -> SexpType -> Bool
$c> :: SexpType -> SexpType -> Bool
> :: SexpType -> SexpType -> Bool
$c>= :: SexpType -> SexpType -> Bool
>= :: SexpType -> SexpType -> Bool
$cmax :: SexpType -> SexpType -> SexpType
max :: SexpType -> SexpType -> SexpType
$cmin :: SexpType -> SexpType -> SexpType
min :: SexpType -> SexpType -> SexpType
Ord, Int -> SexpType -> ShowS
[SexpType] -> ShowS
SexpType -> String
(Int -> SexpType -> ShowS)
-> (SexpType -> String) -> ([SexpType] -> ShowS) -> Show SexpType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SexpType -> ShowS
showsPrec :: Int -> SexpType -> ShowS
$cshow :: SexpType -> String
show :: SexpType -> String
$cshowList :: [SexpType] -> ShowS
showList :: [SexpType] -> ShowS
Show)

sexpType :: SexpF r -> SexpType
sexpType :: forall r. SexpF r -> SexpType
sexpType = \case
  SexpAtomF Atom
at -> AtomType -> SexpType
SexpTypeAtom (Atom -> AtomType
atomType Atom
at)
  SexpListF Brace
b Seq r
_ -> Brace -> SexpType
SexpTypeList Brace
b
  SexpQuoteF r
_ -> SexpType
SexpTypeQuote
  SexpUnquoteF r
_ -> SexpType
SexpTypeUnquote
  SexpDocF Doc
_ r
_ -> SexpType
SexpTypeDoc

class IsSexp s where
  toSexp :: s -> Sexp

instance IsSexp Sexp where
  toSexp :: Sexp -> Sexp
toSexp = Sexp -> Sexp
forall a. a -> a
id

pattern SexpAtom :: Atom -> Sexp
pattern $mSexpAtom :: forall {r}. Sexp -> (Atom -> r) -> ((# #) -> r) -> r
$bSexpAtom :: Atom -> Sexp
SexpAtom x = Sexp (SexpAtomF x)

pattern SexpList :: Brace -> Seq Sexp -> Sexp
pattern $mSexpList :: forall {r}. Sexp -> (Brace -> Seq Sexp -> r) -> ((# #) -> r) -> r
$bSexpList :: Brace -> Seq Sexp -> Sexp
SexpList x y = Sexp (SexpListF x y)

pattern SexpQuote :: Sexp -> Sexp
pattern $mSexpQuote :: forall {r}. Sexp -> (Sexp -> r) -> ((# #) -> r) -> r
$bSexpQuote :: Sexp -> Sexp
SexpQuote x = Sexp (SexpQuoteF x)

pattern SexpUnquote :: Sexp -> Sexp
pattern $mSexpUnquote :: forall {r}. Sexp -> (Sexp -> r) -> ((# #) -> r) -> r
$bSexpUnquote :: Sexp -> Sexp
SexpUnquote x = Sexp (SexpUnquoteF x)

pattern SexpDoc :: Doc -> Sexp -> Sexp
pattern $mSexpDoc :: forall {r}. Sexp -> (Doc -> Sexp -> r) -> ((# #) -> r) -> r
$bSexpDoc :: Doc -> Sexp -> Sexp
SexpDoc x y = Sexp (SexpDocF x y)

{-# COMPLETE SexpAtom, SexpList, SexpQuote, SexpUnquote, SexpDoc #-}