251 lines
6.2 KiB
Haskell
251 lines
6.2 KiB
Haskell
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE ApplicativeDo #-}
|
|
module Gyehoek.Sexp.Syntax
|
|
( DatumF(..)
|
|
, Simple(..)
|
|
, CompoundF(..)
|
|
, Prefix(..)
|
|
, Delimiter(..)
|
|
, Label(..)
|
|
, SourcePos(..)
|
|
, Datum
|
|
, Cofree((:<))
|
|
, Fix(..)
|
|
, Compound
|
|
, Indentation(..)
|
|
, Syn(..)
|
|
, pattern Simple
|
|
, pattern Compound
|
|
, pattern Labeled
|
|
, pattern LabelRef
|
|
, pattern Meta
|
|
, pattern MetaSplice
|
|
, pattern Abbrev
|
|
, pattern Vector
|
|
, pattern DotList
|
|
, pattern Gyehoek.Sexp.Syntax.List
|
|
, syntax
|
|
, indentation
|
|
, adorn
|
|
, indentWith
|
|
, pattern Bytevector
|
|
, pattern Symbol
|
|
, pattern String
|
|
, pattern Character
|
|
, pattern Number
|
|
, pattern Boolean
|
|
, Ann(..)
|
|
, noAnn
|
|
, ann
|
|
, pattern List'
|
|
, position
|
|
, stripAnn
|
|
) where
|
|
|
|
import Language.Haskell.TH.Syntax (Lift (lift), liftData)
|
|
import Data.Scientific (Scientific)
|
|
import Data.ByteString (ByteString)
|
|
import Gyehoek.Prelude hiding ((:<), Simple)
|
|
import Text.Megaparsec.Pos (SourcePos(..), sourcePosPretty)
|
|
import Control.Comonad.Cofree (Cofree((:<)), _extract, _unwrap)
|
|
import Data.Fix (Fix (..))
|
|
import Data.Functor.Foldable
|
|
import Text.Show.Deriving (deriveShow1)
|
|
import Data.Eq.Deriving (deriveEq1)
|
|
import qualified Control.Comonad.Trans.Cofree as F
|
|
import Prettyprinter (Pretty (pretty), viaShow)
|
|
import Gyehoek.Lift1 (Lift1 (liftLift))
|
|
import Data.Data (Typeable, cast)
|
|
import Language.Haskell.TH
|
|
import qualified Data.Text as T
|
|
import Control.Comonad.Trans.Cofree (tailF)
|
|
|
|
|
|
data DatumF a
|
|
= SimpleF Simple
|
|
| CompoundF (CompoundF a)
|
|
| LabeledF Label a
|
|
| LabelRefF Label
|
|
| MetaF Text
|
|
| MetaSpliceF Text
|
|
deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
|
|
deriving anyclass (NFData)
|
|
|
|
data Simple
|
|
= SimpleBoolean Bool
|
|
| SimpleNumber Scientific
|
|
| SimpleCharacter Char
|
|
| SimpleString Text
|
|
| SimpleSymbol Text
|
|
| SimpleBytevector ByteString
|
|
deriving stock (Show, Eq, Data, Generic, Lift)
|
|
deriving anyclass (NFData)
|
|
|
|
data CompoundF a
|
|
= ListF Indentation (List a)
|
|
| DotListF (NonEmpty a) a
|
|
| VectorF (List a)
|
|
| AbbrevF Prefix a
|
|
deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
|
|
deriving anyclass (NFData)
|
|
|
|
data Prefix
|
|
= Quote | Backtick | Comma | CommaAt
|
|
deriving stock (Show, Eq, Data, Generic, Lift)
|
|
deriving anyclass (NFData)
|
|
|
|
data Delimiter
|
|
= Paren
|
|
| Square
|
|
| Curly
|
|
deriving stock (Show, Eq, Data, Generic, Lift)
|
|
deriving anyclass (NFData)
|
|
|
|
newtype Label = MkLabel Natural
|
|
deriving stock (Data, Generic, Lift)
|
|
deriving newtype (Eq, Ord, Show)
|
|
deriving anyclass (NFData)
|
|
|
|
|
|
|
|
type Datum = Cofree DatumF Ann
|
|
type Compound = CompoundF Datum
|
|
|
|
data Indentation
|
|
= NSpecial Int
|
|
| Ordinary
|
|
deriving stock (Data, Eq, Generic, Show, Lift, Read)
|
|
deriving anyclass (NFData)
|
|
|
|
data Syn
|
|
= SynMacro
|
|
| SynBuiltin
|
|
| SynProcedure
|
|
| SynParen Int
|
|
| SynString
|
|
| SynConstant
|
|
| SynNone
|
|
deriving (Show, Read, Data, Generic, Eq, Lift)
|
|
|
|
data Ann = MkAnn
|
|
{ syntax :: Syn
|
|
, position :: Maybe SourcePos
|
|
}
|
|
deriving (Show, Data, Eq, Generic)
|
|
|
|
noAnn :: Ann
|
|
noAnn = MkAnn
|
|
{ syntax = SynNone
|
|
, position = Nothing
|
|
}
|
|
|
|
-- requisite of the Pretty instance for invertible-grammar's error type.
|
|
instance Pretty Ann where
|
|
pretty = pretty . maybe "<unknown>" sourcePosPretty . view #position
|
|
|
|
deriveShow1 ''CompoundF
|
|
deriveEq1 ''CompoundF
|
|
deriveShow1 ''DatumF
|
|
deriveEq1 ''DatumF
|
|
|
|
|
|
--- modification and extraction of annotations
|
|
|
|
ann :: Lens' Datum Ann
|
|
ann = _extract
|
|
|
|
syntax :: Lens' Datum Syn
|
|
syntax = ann . #syntax
|
|
|
|
position :: Lens' Datum (Maybe SourcePos)
|
|
position = ann . #position
|
|
|
|
indentation :: Traversal' Datum Indentation
|
|
indentation k (syn :< CompoundF (ListF ind xs)) = do
|
|
ind' <- k ind
|
|
pure $ syn :< CompoundF (ListF ind' xs)
|
|
indentation k a = pure a
|
|
|
|
adorn :: Syn -> Datum -> Datum
|
|
adorn = set syntax
|
|
|
|
indentWith :: Indentation -> Datum -> Datum
|
|
indentWith = set indentation
|
|
|
|
stripAnn :: Datum -> Fix DatumF
|
|
stripAnn = hoist tailF
|
|
|
|
|
|
--- pattern synonyms
|
|
|
|
pattern Simple :: Simple -> Datum
|
|
pattern Simple a <- _ :< SimpleF a
|
|
where Simple a = noAnn :< SimpleF a
|
|
|
|
pattern Compound :: CompoundF Datum -> Datum
|
|
pattern Compound a <- _ :< CompoundF a
|
|
where Compound a = noAnn :< CompoundF a
|
|
|
|
pattern Labeled :: Label -> Datum -> Datum
|
|
pattern Labeled l a <- _ :< LabeledF l a
|
|
where Labeled l a = noAnn :< LabeledF l a
|
|
|
|
pattern LabelRef :: Label -> Datum
|
|
pattern LabelRef l <- _ :< LabelRefF l
|
|
where LabelRef l = noAnn :< LabelRefF l
|
|
|
|
pattern MetaSplice :: Text -> Datum
|
|
pattern MetaSplice x <- _ :< MetaSpliceF x
|
|
where MetaSplice x = noAnn :< MetaSpliceF x
|
|
|
|
pattern Meta :: Text -> Datum
|
|
pattern Meta x <- _ :< MetaF x
|
|
where Meta x = noAnn :< MetaF x
|
|
|
|
pattern List :: List Datum -> Datum
|
|
pattern List a <- _ :< CompoundF (ListF _ a)
|
|
where List a = noAnn :< CompoundF (ListF Ordinary a)
|
|
|
|
pattern List' :: Indentation -> List Datum -> Datum
|
|
pattern List' ind a <- _ :< CompoundF (ListF ind a)
|
|
where List' ind a = noAnn :< CompoundF (ListF ind a)
|
|
|
|
pattern DotList :: NonEmpty Datum -> Datum -> Datum
|
|
pattern DotList xs x <- _ :< CompoundF (DotListF xs x)
|
|
where DotList xs x = noAnn :< CompoundF (DotListF xs x)
|
|
|
|
pattern Vector :: [Datum] -> Datum
|
|
pattern Vector xs <- _ :< CompoundF (VectorF xs)
|
|
where Vector xs = noAnn :< CompoundF (VectorF xs)
|
|
|
|
pattern Abbrev :: Prefix -> Datum -> Datum
|
|
pattern Abbrev p a <- _ :< CompoundF (AbbrevF p a)
|
|
where Abbrev p a = noAnn :< CompoundF (AbbrevF p a)
|
|
|
|
pattern Boolean a = Simple (SimpleBoolean a)
|
|
pattern Number a = Simple (SimpleNumber a)
|
|
pattern Character a = Simple (SimpleCharacter a)
|
|
pattern String a = Simple (SimpleString a)
|
|
pattern Symbol a = Simple (SimpleSymbol a)
|
|
pattern Bytevector a = Simple (SimpleBytevector a)
|
|
|
|
|
|
--- Lift1 instances
|
|
|
|
instance Lift1 DatumF where
|
|
liftLift l = \case
|
|
SimpleF s -> [|SimpleF $(lift s)|]
|
|
CompoundF c -> [|CompoundF $(liftLift l c)|]
|
|
LabeledF lbl x -> [|LabeledF $(lift lbl) $(l x)|]
|
|
LabelRefF lbl -> [|LabelRefF $(lift lbl)|]
|
|
MetaF x -> [|MetaF $(lift x)|]
|
|
MetaSpliceF x -> [|MetaSpliceF $(lift x)|]
|
|
|
|
instance Lift1 CompoundF where
|
|
liftLift l = \case
|
|
ListF ind xs -> [|ListF $(lift ind) $(liftLift l xs)|]
|
|
DotListF xs t -> [|DotListF $(liftLift l xs) $(l t)|]
|
|
VectorF xs -> [|VectorF $(liftLift l xs)|]
|
|
AbbrevF p x -> [|AbbrevF $(lift p) $(l x)|]
|