Data.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}

module Descript.Lex.Data
  ( module Descript.Lex.Data.Atom
  , Punc (..)
  , Lex (..)
  , lexToSymbol
  , lexToPrim
  ) where

import Descript.Lex.Data.Atom
import Descript.Misc
import Text.Megaparsec.Error
import Core.Data.String

-- | Symbolic characters and simple keywords, mainly used to group data.
data Punc an
  = Sep an
  | PhaseSep an
  | Period an
  | Colon an
  | Question an
  | Union an
  | PathFwd an
  | PathBwd an
  | ArrowEqFwd an
  | OpenBracket an
  | CloseBracket an
  | OpenBrace an
  | CloseBrace an
  | DeclModule an
  | DeclImport an
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | A single lexeme token. Easy and fast to parse from source text, but
-- not nested and might be syntactically invalid when further parsed.
data Lex an
  = LexPunc (Punc an)
  | LexSymbol (Symbol an)
  | LexPrim (Prim an)
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

instance Ann Lex where
  getAnn (LexPunc punc) = getAnn punc
  getAnn (LexSymbol sym) = getAnn sym
  getAnn (LexPrim prim) = getAnn prim

instance Ann Punc where
  getAnn (Sep ann) = ann
  getAnn (PhaseSep ann) = ann
  getAnn (Period ann) = ann
  getAnn (Colon ann) = ann
  getAnn (Question ann) = ann
  getAnn (Union ann) = ann
  getAnn (PathFwd ann) = ann
  getAnn (PathBwd ann) = ann
  getAnn (ArrowEqFwd ann) = ann
  getAnn (OpenBracket ann) = ann
  getAnn (CloseBracket ann) = ann
  getAnn (OpenBrace ann) = ann
  getAnn (CloseBrace ann) = ann
  getAnn (DeclModule ann) = ann
  getAnn (DeclImport ann) = ann

instance Printable Lex where
  aprintRec sub (LexPunc punc) = sub punc
  aprintRec sub (LexSymbol symbol) = sub symbol
  aprintRec sub (LexPrim prim) = sub prim

instance Printable Punc where
  aprint (Sep _) = ", "
  aprint (PhaseSep _) = "---"
  aprint (Period _) = "."
  aprint (Colon _) = ": "
  aprint (Question _) = "?"
  aprint (Union _) = " | "
  aprint (PathFwd _) = ">"
  aprint (PathBwd _) = "<"
  aprint (ArrowEqFwd _) = "=>"
  aprint (OpenBracket _) = "["
  aprint (CloseBracket _) = "]"
  aprint (OpenBrace _) = "{"
  aprint (CloseBrace _) = "}"
  aprint (DeclModule _) = "module "
  aprint (DeclImport _) = "import "

instance (Show an) => ShowToken (Lex an) where
  showTokens = summary

instance (Show an) => Summary (Lex an) where
  summaryRec = pprintSummaryRec

instance (Show an) => Summary (Punc an) where
  summary punc = "'" ++ trim (pprintStr punc) ++ "'"

-- | If the lexeme is a symbol, unwraps it.
lexToSymbol :: Lex an -> Maybe (Symbol an)
lexToSymbol (LexPunc _) = Nothing
lexToSymbol (LexSymbol sym) = Just sym
lexToSymbol (LexPrim _) = Nothing

-- | If the lexeme is a primitive, unwraps it.
lexToPrim :: Lex an -> Maybe (Prim an)
lexToPrim (LexPunc _) = Nothing
lexToPrim (LexSymbol _) = Nothing
lexToPrim (LexPrim prim) = Just prim