Term.hs

{-# LANGUAGE OverloadedStrings #-}

{- | Symbols and concrete terms accepted by ECTAs.

Terms are ordinary first-order trees. They are the concrete values produced by
the enumeration API in "Data.ECTA".
-}
module Data.ECTA.Internal.Term (
    Symbol (.., Symbol),
    Term (..),
) where

import Data.Hashable (Hashable (..))
import qualified Data.Interned as OrigInterned
import Data.Maybe (maybeToList)
import Data.String (IsString (..))
import Data.Text (Text)
import qualified Data.Text as Text
import Text.Read (Read (..))

import Data.Interned.Text (InternedText, internedTextId)

import Data.ECTA.Paths
import Data.Text.Extended.Pretty

---------------------------------------------------------------
-------------------------- Symbols ----------------------------
---------------------------------------------------------------

-- | Interned term or edge symbol.
data Symbol = Symbol' {-# UNPACK #-} !InternedText
    deriving (Eq, Ord)

-- | Build or match a symbol from text.
pattern Symbol :: Text -> Symbol
pattern Symbol t <- Symbol' (OrigInterned.unintern -> t)
    where
        Symbol t = Symbol' (OrigInterned.intern t)

{-# COMPLETE Symbol #-}

instance Pretty Symbol where
    pretty (Symbol t) = t

instance Show Symbol where
    show (Symbol it) = show it

instance Hashable Symbol where
    hashWithSalt s (Symbol' t) = s `hashWithSalt` (internedTextId t)

instance IsString Symbol where
    fromString = Symbol . fromString

instance Read Symbol where
    readPrec = Symbol <$> readPrec

---------------------------------------------------------------
---------------------------- Terms ----------------------------
---------------------------------------------------------------

-- | Concrete first-order term.
data Term = Term !Symbol ![Term]
    deriving (Eq, Ord, Read, Show)

instance Hashable Term where
    hashWithSalt salt (Term symbol children) =
        salt `hashWithSalt` symbol `hashWithSalt` children

instance Pretty Term where
    pretty (Term s []) = pretty s
    pretty (Term s ts) = pretty s <> "(" <> (Text.intercalate ", " $ map pretty ts) <> ")"

---------------------
------ Term ops
---------------------

atMay :: Int -> [a] -> Maybe a
atMay i xs
    | i < 0 = Nothing
    | otherwise = case drop i xs of
        x : _ -> Just x
        [] -> Nothing

adjustAt :: Int -> (a -> a) -> [a] -> [a]
adjustAt i f xs
    | i < 0 = xs
    | otherwise = case splitAt i xs of
        (prefix, x : suffix) -> prefix ++ f x : suffix
        _ -> xs

instance Pathable Term Term where
    type Emptyable Term = Maybe Term

    getPath EmptyPath t = Just t
    getPath (ConsPath p ps) (Term _ ts) = case atMay p ts of
        Nothing -> Nothing
        Just t -> getPath ps t

    getAllAtPath p t = maybeToList $ getPath p t

    modifyAtPath f EmptyPath t = f t
    modifyAtPath f (ConsPath p ps) (Term s ts) = Term s (adjustAt p (modifyAtPath f ps) ts)