{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT

module XMIR (programToXMIR, printXMIR, toName, parseXMIR, parseXMIRThrows, xmirToPhi, XmirContext (XmirContext)) where

import Ast
import Control.Exception (Exception (displayException), SomeException, throwIO)
import Control.Exception.Base (Exception)
import qualified Data.Bifunctor
import Data.Foldable (foldlM)
import Data.List (intercalate)
import qualified Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (catMaybes, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import Data.Time
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Version (showVersion)
import Misc
import Paths_phino (version)
import Pretty (PrintMode, prettyAttribute, prettyBinding, prettyExpression, prettyProgram')
import Text.Printf (printf)
import Text.Read (readMaybe)
import qualified Text.Read as TR
import Text.XML
import qualified Text.XML.Cursor as C

data XmirContext = XmirContext
  { XmirContext -> Bool
omitListing :: Bool,
    XmirContext -> Bool
omitComments :: Bool,
    XmirContext -> PrintMode
printMode :: PrintMode
  }

-- @todo #116:30min Refactor XMIR module. This module became so big and hard to read.
--  Now it's responsible for 3 different operations: 1) converting Phi AST to XML Document Ast,
--  2) printing XML Document, 3) parsing XMIR to Phi AST. I think we should separate the logic
--  in order to keep modules as little as possible.
data XMIRException
  = UnsupportedExpression {XMIRException -> Expression
expr :: Expression}
  | UnsupportedBinding {XMIRException -> Binding
binding :: Binding}
  | CouldNotParseXMIR {XMIRException -> String
message :: String}
  | InvalidXMIRFormat {message :: String, XMIRException -> Cursor
cursor :: C.Cursor}
  deriving (Show XMIRException
Typeable XMIRException
(Typeable XMIRException, Show XMIRException) =>
(XMIRException -> SomeException)
-> (SomeException -> Maybe XMIRException)
-> (XMIRException -> String)
-> Exception XMIRException
SomeException -> Maybe XMIRException
XMIRException -> String
XMIRException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: XMIRException -> SomeException
toException :: XMIRException -> SomeException
$cfromException :: SomeException -> Maybe XMIRException
fromException :: SomeException -> Maybe XMIRException
$cdisplayException :: XMIRException -> String
displayException :: XMIRException -> String
Exception)

instance Show XMIRException where
  show :: XMIRException -> String
show UnsupportedExpression {Expression
expr :: XMIRException -> Expression
expr :: Expression
..} = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"XMIR does not support such expression: %s" (Expression -> String
prettyExpression Expression
expr)
  show UnsupportedBinding {Binding
binding :: XMIRException -> Binding
binding :: Binding
..} = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"XMIR does not support such bindings: %s" (Binding -> String
prettyBinding Binding
binding)
  show CouldNotParseXMIR {String
message :: XMIRException -> String
message :: String
..} = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Couldn't parse given XMIR, cause: %s" String
message
  show InvalidXMIRFormat {String
Cursor
message :: XMIRException -> String
cursor :: XMIRException -> Cursor
message :: String
cursor :: Cursor
..} =
    String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
      String
"Couldn't traverse though given XMIR, cause: %s\nXMIR:\n%s"
      String
message
      ( case Cursor -> Node
forall node. Cursor node -> node
C.node Cursor
cursor of
          NodeElement Element
el -> Document -> String
printXMIR (Prologue -> Element -> [Miscellaneous] -> Document
Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
Prologue [] Maybe Doctype
forall a. Maybe a
Nothing []) Element
el [])
          Node
_ -> String
"Unknown"
      )

toName :: String -> Name
toName :: String -> Name
toName String
str = Text -> Maybe Text -> Maybe Text -> Name
Name (String -> Text
T.pack String
str) Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing

element :: String -> [(String, String)] -> [Node] -> Element
element :: String -> [(String, String)] -> [Node] -> Element
element String
name [(String, String)]
attrs [Node]
children = do
  let name' :: Name
name' = String -> Name
toName String
name
      attrs' :: Map Name Text
attrs' = [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (((String, String) -> (Name, Text))
-> [(String, String)] -> [(Name, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Name)
-> (String -> Text) -> (String, String) -> (Name, Text)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Data.Bifunctor.bimap String -> Name
toName String -> Text
T.pack) [(String, String)]
attrs)
  Name -> Map Name Text -> [Node] -> Element
Element Name
name' Map Name Text
attrs' [Node]
children

object :: [(String, String)] -> [Node] -> Node
object :: [(String, String)] -> [Node] -> Node
object [(String, String)]
attrs [Node]
children = Element -> Node
NodeElement (String -> [(String, String)] -> [Node] -> Element
element String
"o" [(String, String)]
attrs [Node]
children)

expression :: Expression -> XmirContext -> IO (String, [Node])
expression :: Expression -> XmirContext -> IO (String, [Node])
expression Expression
ExThis XmirContext
_ = (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"$", [])
expression Expression
ExGlobal XmirContext
_ = (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"Q", [])
expression (ExFormation [Binding]
bds) XmirContext
ctx = do
  [Node]
nested <- [Binding] -> XmirContext -> IO [Node]
nestedBindings [Binding]
bds XmirContext
ctx
  (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"", [Node]
nested)
expression (ExDispatch Expression
expr Attribute
attr) XmirContext
ctx = do
  (String
base, [Node]
children) <- Expression -> XmirContext -> IO (String, [Node])
expression Expression
expr XmirContext
ctx
  let attr' :: String
attr' = Attribute -> String
prettyAttribute Attribute
attr
  if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
base
    then (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
attr', [[(String, String)] -> [Node] -> Node
object [] [Node]
children])
    else
      if String -> Char
forall a. HasCallStack => [a] -> a
head String
base Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Bool -> Bool
not ([Node] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node]
children)
        then (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
attr', [[(String, String)] -> [Node] -> Node
object [(String
"base", String
base)] [Node]
children])
        else (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
base String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
attr'), [Node]
children)
expression (DataObject String
"number" String
bytes) XmirContext {Bool
PrintMode
omitListing :: XmirContext -> Bool
omitComments :: XmirContext -> Bool
printMode :: XmirContext -> PrintMode
omitListing :: Bool
omitComments :: Bool
printMode :: PrintMode
..} =
  let bts :: Node
bts =
        [(String, String)] -> [Node] -> Node
object
          [(String
"as", Attribute -> String
prettyAttribute (Integer -> Attribute
AtAlpha Integer
0)), (String
"base", String
"Q.org.eolang.bytes")]
          [[(String, String)] -> [Node] -> Node
object [] [Text -> Node
NodeContent (String -> Text
T.pack String
bytes)]]
   in (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( String
"Q.org.eolang.number",
          if Bool
omitComments
            then [Node
bts]
            else
              [ Text -> Node
NodeComment (String -> Text
T.pack ((Integer -> String)
-> (Double -> String) -> Either Integer Double -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Integer -> String
forall a. Show a => a -> String
show Double -> String
forall a. Show a => a -> String
show (String -> Either Integer Double
hexToNum String
bytes))),
                Node
bts
              ]
        )
expression (DataObject String
"string" String
bytes) XmirContext {Bool
PrintMode
omitListing :: XmirContext -> Bool
omitComments :: XmirContext -> Bool
printMode :: XmirContext -> PrintMode
omitListing :: Bool
omitComments :: Bool
printMode :: PrintMode
..} =
  let bts :: Node
bts =
        [(String, String)] -> [Node] -> Node
object
          [(String
"as", Attribute -> String
prettyAttribute (Integer -> Attribute
AtAlpha Integer
0)), (String
"base", String
"Q.org.eolang.bytes")]
          [[(String, String)] -> [Node] -> Node
object [] [Text -> Node
NodeContent (String -> Text
T.pack String
bytes)]]
   in (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( String
"Q.org.eolang.string",
          if Bool
omitComments
            then [Node
bts]
            else
              [ Text -> Node
NodeComment (String -> Text
T.pack (Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
hexToStr String
bytes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")),
                Node
bts
              ]
        )
expression (ExApplication Expression
expr (BiTau Attribute
attr Expression
texpr)) XmirContext
ctx = do
  (String
base, [Node]
children) <- Expression -> XmirContext -> IO (String, [Node])
expression Expression
expr XmirContext
ctx
  (String
base', [Node]
children') <- Expression -> XmirContext -> IO (String, [Node])
expression Expression
texpr XmirContext
ctx
  let as :: String
as = Attribute -> String
prettyAttribute Attribute
attr
      attrs :: [(String, String)]
attrs =
        if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
base'
          then [(String
"as", String
as)]
          else [(String
"as", String
as), (String
"base", String
base')]
  (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
base, [Node]
children [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ [[(String, String)] -> [Node] -> Node
object [(String, String)]
attrs [Node]
children'])
expression (ExApplication (ExFormation [Binding]
bds) Binding
tau) XmirContext
_ = XMIRException -> IO (String, [Node])
forall e a. Exception e => e -> IO a
throwIO (Expression -> XMIRException
UnsupportedExpression (Expression -> Binding -> Expression
ExApplication ([Binding] -> Expression
ExFormation [Binding]
bds) Binding
tau))
expression Expression
expr XmirContext
_ = XMIRException -> IO (String, [Node])
forall e a. Exception e => e -> IO a
throwIO (Expression -> XMIRException
UnsupportedExpression Expression
expr)

nestedBindings :: [Binding] -> XmirContext -> IO [Node]
nestedBindings :: [Binding] -> XmirContext -> IO [Node]
nestedBindings [Binding]
bds XmirContext
ctx = [Maybe Node] -> [Node]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Node] -> [Node]) -> IO [Maybe Node] -> IO [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Binding -> IO (Maybe Node)) -> [Binding] -> IO [Maybe Node]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Binding -> XmirContext -> IO (Maybe Node)
`formationBinding` XmirContext
ctx) [Binding]
bds

formationBinding :: Binding -> XmirContext -> IO (Maybe Node)
formationBinding :: Binding -> XmirContext -> IO (Maybe Node)
formationBinding (BiTau (AtLabel String
label) (ExFormation [Binding]
bds)) XmirContext
ctx = do
  [Node]
inners <- [Binding] -> XmirContext -> IO [Node]
nestedBindings [Binding]
bds XmirContext
ctx
  Maybe Node -> IO (Maybe Node)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> Maybe Node
forall a. a -> Maybe a
Just ([(String, String)] -> [Node] -> Node
object [(String
"name", String
label)] [Node]
inners))
formationBinding (BiTau (AtLabel String
label) Expression
expr) XmirContext
ctx = do
  (String
base, [Node]
children) <- Expression -> XmirContext -> IO (String, [Node])
expression Expression
expr XmirContext
ctx
  Maybe Node -> IO (Maybe Node)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> Maybe Node
forall a. a -> Maybe a
Just ([(String, String)] -> [Node] -> Node
object [(String
"name", String
label), (String
"base", String
base)] [Node]
children))
formationBinding (BiTau Attribute
AtRho Expression
_) XmirContext
_ = Maybe Node -> IO (Maybe Node)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Node
forall a. Maybe a
Nothing
formationBinding (BiDelta String
bytes) XmirContext
_ = Maybe Node -> IO (Maybe Node)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> Maybe Node
forall a. a -> Maybe a
Just (Text -> Node
NodeContent (String -> Text
T.pack String
bytes)))
formationBinding (BiLambda String
func) XmirContext
_ = Maybe Node -> IO (Maybe Node)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> Maybe Node
forall a. a -> Maybe a
Just ([(String, String)] -> [Node] -> Node
object [(String
"name", String
"λ")] []))
formationBinding (BiVoid Attribute
AtRho) XmirContext
_ = Maybe Node -> IO (Maybe Node)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Node
forall a. Maybe a
Nothing
formationBinding (BiVoid Attribute
AtPhi) XmirContext
_ = Maybe Node -> IO (Maybe Node)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> Maybe Node
forall a. a -> Maybe a
Just ([(String, String)] -> [Node] -> Node
object [(String
"name", String
"φ"), (String
"base", String
"∅")] []))
formationBinding (BiVoid (AtLabel String
label)) XmirContext
_ = Maybe Node -> IO (Maybe Node)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> Maybe Node
forall a. a -> Maybe a
Just ([(String, String)] -> [Node] -> Node
object [(String
"name", String
label), (String
"base", String
"∅")] []))
formationBinding Binding
binding XmirContext
_ = XMIRException -> IO (Maybe Node)
forall e a. Exception e => e -> IO a
throwIO (Binding -> XMIRException
UnsupportedBinding Binding
binding)

rootExpression :: Expression -> XmirContext -> IO Node
rootExpression :: Expression -> XmirContext -> IO Node
rootExpression (ExFormation [Binding
bd, BiVoid Attribute
AtRho]) XmirContext
ctx = do
  [Node
bd'] <- [Binding] -> XmirContext -> IO [Node]
nestedBindings [Binding
bd] XmirContext
ctx
  Node -> IO Node
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Node
bd'
rootExpression Expression
expr XmirContext
_ = XMIRException -> IO Node
forall e a. Exception e => e -> IO a
throwIO (Expression -> XMIRException
UnsupportedExpression Expression
expr)

-- Extract package from given expression
-- The function returns tuple (X, Y), where
-- - X: list of package parts
-- - Y: root object expression
-- @todo #197:30min Make patterns with L> Package softer. Right now we expect L> Package only in the end
--  of the formation bindings list. That's not really correct since this binding may be anywhere. Let's fix it
getPackage :: Expression -> IO ([String], Expression)
getPackage :: Expression -> IO ([String], Expression)
getPackage (ExFormation [BiTau (AtLabel String
label) (ExFormation [Binding
bd, BiLambda String
"Package", BiVoid Attribute
AtRho]), BiVoid Attribute
AtRho]) = do
  ([String]
pckg, Expression
expr') <- Expression -> IO ([String], Expression)
getPackage ([Binding] -> Expression
ExFormation [Binding
bd, String -> Binding
BiLambda String
"Package", Attribute -> Binding
BiVoid Attribute
AtRho])
  ([String], Expression) -> IO ([String], Expression)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
label String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
pckg, Expression
expr')
getPackage (ExFormation [BiTau (AtLabel String
label) (ExFormation [Binding
bd, BiLambda String
"Package", BiVoid Attribute
AtRho]), BiLambda String
"Package", BiVoid Attribute
AtRho]) = do
  ([String]
pckg, Expression
expr') <- Expression -> IO ([String], Expression)
getPackage ([Binding] -> Expression
ExFormation [Binding
bd, String -> Binding
BiLambda String
"Package", Attribute -> Binding
BiVoid Attribute
AtRho])
  ([String], Expression) -> IO ([String], Expression)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
label String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
pckg, Expression
expr')
getPackage (ExFormation [BiTau Attribute
attr Expression
expr, BiLambda String
"Package", BiVoid Attribute
AtRho]) = ([String], Expression) -> IO ([String], Expression)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [Binding] -> Expression
ExFormation [Attribute -> Expression -> Binding
BiTau Attribute
attr Expression
expr, Attribute -> Binding
BiVoid Attribute
AtRho])
getPackage (ExFormation [Binding
bd, BiVoid Attribute
AtRho]) = ([String], Expression) -> IO ([String], Expression)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [Binding] -> Expression
ExFormation [Binding
bd, Attribute -> Binding
BiVoid Attribute
AtRho])
getPackage Expression
expr = IOError -> IO ([String], Expression)
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Can't extract package from given expression:\n %s" (Expression -> String
prettyExpression Expression
expr)))

metasWithPackage :: String -> Node
metasWithPackage :: String -> Node
metasWithPackage String
pckg =
  Element -> Node
NodeElement
    ( String -> [(String, String)] -> [Node] -> Element
element
        String
"metas"
        []
        [ Element -> Node
NodeElement
            ( String -> [(String, String)] -> [Node] -> Element
element
                String
"meta"
                []
                [ Element -> Node
NodeElement (String -> [(String, String)] -> [Node] -> Element
element String
"head" [] [Text -> Node
NodeContent (String -> Text
T.pack String
"package")]),
                  Element -> Node
NodeElement (String -> [(String, String)] -> [Node] -> Element
element String
"tail" [] [Text -> Node
NodeContent (String -> Text
T.pack String
pckg)]),
                  Element -> Node
NodeElement (String -> [(String, String)] -> [Node] -> Element
element String
"part" [] [Text -> Node
NodeContent (String -> Text
T.pack String
pckg)])
                ]
            )
        ]
    )

time :: UTCTime -> String
time :: UTCTime -> String
time UTCTime
now = do
  let base :: String
base = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S" UTCTime
now
      posix :: POSIXTime
posix = UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
now
      fractional :: Double
      fractional :: Double
fractional = POSIXTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac POSIXTime
posix Double -> Double -> Double
forall a. Num a => a -> a -> a
- Integer -> Double
forall a. Num a => Integer -> a
fromInteger (POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor POSIXTime
posix)
      nanos :: Int
nanos = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
fractional Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1_000_000_000) :: Int
  String
base String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%09d" Int
nanos String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Z"

programToXMIR :: Program -> XmirContext -> IO Document
programToXMIR :: Program -> XmirContext -> IO Document
programToXMIR (Program Expression
expr) XmirContext
ctx = do
  ([String]
pckg, Expression
expr') <- Expression -> IO ([String], Expression)
getPackage Expression
expr
  Node
root <- Expression -> XmirContext -> IO Node
rootExpression Expression
expr' XmirContext
ctx
  UTCTime
now <- IO UTCTime
getCurrentTime
  let phi :: String
phi = Program -> PrintMode -> String
prettyProgram' (Expression -> Program
Program Expression
expr) (XmirContext -> PrintMode
printMode XmirContext
ctx)
      listing :: String
listing =
        if XmirContext -> Bool
omitListing XmirContext
ctx
          then Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> [String]
lines String
phi)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" lines of phi"
          else String
phi
      listing' :: Node
listing' = Element -> Node
NodeElement (String -> [(String, String)] -> [Node] -> Element
element String
"listing" [] [Text -> Node
NodeContent (String -> Text
T.pack String
listing)])
      metas :: Node
metas = String -> Node
metasWithPackage (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
pckg)
  Document -> IO Document
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Prologue -> Element -> [Miscellaneous] -> Document
Document
        ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
Prologue [] Maybe Doctype
forall a. Maybe a
Nothing [])
        ( String -> [(String, String)] -> [Node] -> Element
element
            String
"object"
            [ (String
"dob", TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S" UTCTime
now),
              (String
"ms", String
"0"),
              (String
"revision", String
"1234567"),
              (String
"time", UTCTime -> String
time UTCTime
now),
              (String
"version", Version -> String
showVersion Version
version),
              (String
"xmlns:xsi", String
"http://www.w3.org/2001/XMLSchema-instance"),
              (String
"xsi:noNamespaceSchemaLocation", String
"https://raw.githubusercontent.com/objectionary/eo/refs/heads/gh-pages/XMIR.xsd")
            ]
            ( if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
pckg
                then [Node
listing', Node
root]
                else [Node
listing', Node
metas, Node
root]
            )
        )
        []
    )

-- Add indentation (2 spaces per level).
indent :: Int -> TB.Builder
indent :: Int -> Builder
indent Int
n = Text -> Builder
TB.fromText (Int -> Text -> Text
T.replicate Int
n (String -> Text
T.pack String
"  "))

newline :: TB.Builder
newline :: Builder
newline = String -> Builder
TB.fromString String
"\n"

-- >>> printElement 0 (element "doc" [("a", ""), ("b", ""), ("c", ""), ("d", ""), ("e", "")] [])
-- "<doc a=\"\" b=\"\" c=\"\" d=\"\" e=\"\"/>\n"
printElement :: Int -> Element -> TB.Builder
printElement :: Int -> Element -> Builder
printElement Int
indentLevel (Element Name
name Map Name Text
attrs [Node]
nodes)
  | [Node] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node]
nodes =
      Int -> Builder
indent Int
indentLevel
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
"<"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.fromText (Name -> Text
nameLocalName Name
name)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
attrsText
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
"/>"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
  | (Node -> Bool) -> [Node] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Node -> Bool
isTextNode [Node]
nodes =
      Int -> Builder
indent Int
indentLevel
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
"<"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.fromText (Name -> Text
nameLocalName Name
name)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
attrsText
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
">"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Node -> Builder) -> [Node] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Builder
printRawText [Node]
nodes)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
"</"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.fromText (Name -> Text
nameLocalName Name
name)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
">"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
  | Bool
otherwise =
      Int -> Builder
indent Int
indentLevel
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
"<"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.fromText (Name -> Text
nameLocalName Name
name)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
attrsText
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
">"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Node -> Builder) -> [Node] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Node -> Builder
printNode (Int
indentLevel Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [Node]
nodes)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
indent Int
indentLevel
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
"</"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.fromText (Name -> Text
nameLocalName Name
name)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
">"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
  where
    attrsText :: Builder
attrsText =
      [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ String -> Builder
TB.fromString String
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.fromText (Name -> Text
nameLocalName Name
k) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
"=\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.fromText Text
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
"\""
          | (Name
k, Text
v) <- Map Name Text -> [(Name, Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name Text
attrs
        ]

    isTextNode :: Node -> Bool
isTextNode (NodeContent Text
_) = Bool
True
    isTextNode Node
_ = Bool
False

    printRawText :: Node -> Builder
printRawText (NodeContent Text
t) = Text -> Builder
TB.fromText Text
t
    printRawText Node
_ = Builder
forall a. Monoid a => a
mempty

-- >>> printNode 0 (NodeComment (T.pack "--hello--"))
-- "<!-- &#45;&#45;hello&#45;&#45; -->\n"
printNode :: Int -> Node -> TB.Builder
printNode :: Int -> Node -> Builder
printNode Int
_ (NodeContent Text
t) = Text -> Builder
TB.fromText Text
t -- print text exactly as-is
printNode Int
i (NodeElement Element
e) = Int -> Element -> Builder
printElement Int
i Element
e -- pretty-print elements
printNode Int
i (NodeComment Text
t) =
  Int -> Builder
indent Int
i
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
"<!-- "
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.fromText (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"--" Text
"&#45;&#45;" Text
t)
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
" -->"
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
printNode Int
_ Node
_ = Builder
forall a. Monoid a => a
mempty

printXMIR :: Document -> String
printXMIR :: Document -> String
printXMIR (Document Prologue
_ Element
root [Miscellaneous]
_) =
  Text -> String
TL.unpack
    ( Builder -> Text
TB.toLazyText
        ( String -> Builder
TB.fromString String
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Element -> Builder
printElement Int
0 Element
root
        )
    )

parseXMIR :: String -> Either String Document
parseXMIR :: String -> Either String Document
parseXMIR String
xmir = case ParseSettings -> Text -> Either SomeException Document
parseText ParseSettings
forall a. Default a => a
def (String -> Text
TL.pack String
xmir) of
  Right Document
doc -> Document -> Either String Document
forall a b. b -> Either a b
Right Document
doc
  Left SomeException
err -> String -> Either String Document
forall a b. a -> Either a b
Left (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err)

parseXMIRThrows :: String -> IO Document
parseXMIRThrows :: String -> IO Document
parseXMIRThrows String
xmir = case String -> Either String Document
parseXMIR String
xmir of
  Right Document
doc -> Document -> IO Document
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Document
doc
  Left String
err -> XMIRException -> IO Document
forall e a. Exception e => e -> IO a
throwIO (String -> XMIRException
CouldNotParseXMIR String
err)

xmirToPhi :: Document -> IO Program
xmirToPhi :: Document -> IO Program
xmirToPhi Document
xmir =
  let doc :: Cursor
doc = Document -> Cursor
C.fromDocument Document
xmir
   in case Cursor -> Node
forall node. Cursor node -> node
C.node Cursor
doc of
        NodeElement Element
el
          | Name -> Text
nameLocalName (Element -> Name
elementName Element
el) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"object" -> do
              Binding
obj <- case Cursor
doc Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o") of
                [Cursor
o] -> Cursor -> [String] -> IO Binding
xmirToFormationBinding Cursor
o []
                [Cursor]
_ -> XMIRException -> IO Binding
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Expected single <o> element in <object>" Cursor
doc)
              let pckg :: [String]
pckg =
                    [ Text -> String
T.unpack Text
t
                      | Cursor
meta <- Cursor
doc Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"metas") (Cursor -> [Cursor]) -> (Cursor -> [Cursor]) -> Cursor -> [Cursor]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
C.&/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"meta"),
                        let heads :: [Text]
heads = Cursor
meta Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"head") (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
C.&/ Cursor -> [Text]
C.content,
                        [Text]
heads [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text
"package"],
                        Text
tail' <- Cursor
meta Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"tail") (Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
C.&/ Cursor -> [Text]
C.content,
                        Text
t <- HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
tail'
                    ]
              if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
pckg
                then Program -> IO Program
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Program
Program ([Binding] -> Expression
ExFormation [Binding
obj, Attribute -> Binding
BiVoid Attribute
AtRho]))
                else
                  let bd :: Binding
bd = (String -> Binding -> Binding) -> Binding -> [String] -> Binding
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
part Binding
acc -> Attribute -> Expression -> Binding
BiTau (String -> Attribute
AtLabel String
part) ([Binding] -> Expression
ExFormation [Binding
acc, String -> Binding
BiLambda String
"Package", Attribute -> Binding
BiVoid Attribute
AtRho])) Binding
obj [String]
pckg
                   in Program -> IO Program
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Program
Program ([Binding] -> Expression
ExFormation [Binding
bd, Attribute -> Binding
BiVoid Attribute
AtRho]))
          | Bool
otherwise -> XMIRException -> IO Program
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Expected single <object> element" Cursor
doc)
        Node
_ -> XMIRException -> IO Program
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"NodeElement is expected as root element" Cursor
doc)

xmirToFormationBinding :: C.Cursor -> [String] -> IO Binding
xmirToFormationBinding :: Cursor -> [String] -> IO Binding
xmirToFormationBinding Cursor
cur [String]
fqn
  | Bool -> Bool
not (String -> Cursor -> Bool
hasAttr String
"name" Cursor
cur) = XMIRException -> IO Binding
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Formation children must have @name attribute" Cursor
cur)
  | Bool -> Bool
not (String -> Cursor -> Bool
hasAttr String
"base" Cursor
cur) = do
      String
name <- String -> Cursor -> IO String
getAttr String
"name" Cursor
cur
      [Binding]
bds <- (Cursor -> IO Binding) -> [Cursor] -> IO [Binding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Cursor -> [String] -> IO Binding
`xmirToFormationBinding` (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
fqn)) (Cursor
cur Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o"))
      case String
name of
        String
"λ" -> Binding -> IO Binding
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Binding
BiLambda (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" (String
"L" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
forall a. [a] -> [a]
reverse [String]
fqn)))
        (Char
'α' : String
_) -> XMIRException -> IO Binding
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Formation child @name can't start with α" Cursor
cur)
        String
"@" -> Binding -> IO Binding
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> Expression -> Binding
BiTau Attribute
AtPhi ([Binding] -> Expression
ExFormation ([Binding] -> [Binding]
withVoidRho [Binding]
bds)))
        String
_ -> Binding -> IO Binding
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> Expression -> Binding
BiTau (String -> Attribute
AtLabel String
name) ([Binding] -> Expression
ExFormation ([Binding] -> [Binding]
withVoidRho [Binding]
bds)))
  | Bool
otherwise = do
      String
name <- String -> Cursor -> IO String
getAttr String
"name" Cursor
cur
      String
base <- String -> Cursor -> IO String
getAttr String
"base" Cursor
cur
      Attribute
attr <- case String
name of
        String
"@" -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
AtPhi
        (Char
'α' : String
_) -> XMIRException -> IO Attribute
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Formation child @name can't start with α" Cursor
cur)
        String
_ -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Attribute
AtLabel String
name)
      case String
base of
        String
"∅" -> Binding -> IO Binding
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> Binding
BiVoid Attribute
attr)
        String
_ -> do
          Expression
expr <- Cursor -> [String] -> IO Expression
xmirToExpression Cursor
cur [String]
fqn
          Binding -> IO Binding
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> Expression -> Binding
BiTau Attribute
attr Expression
expr)

xmirToExpression :: C.Cursor -> [String] -> IO Expression
xmirToExpression :: Cursor -> [String] -> IO Expression
xmirToExpression Cursor
cur [String]
fqn
  | String -> Cursor -> Bool
hasAttr String
"base" Cursor
cur = do
      String
base <- String -> Cursor -> IO String
getAttr String
"base" Cursor
cur
      case String
base of
        Char
'.' : String
rest ->
          if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest
            then XMIRException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"The @base attribute can't be just '.'" Cursor
cur)
            else
              let args :: [Cursor]
args = Cursor
cur Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o")
               in if [Cursor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cursor]
args
                    then XMIRException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Element with @base='%s' must have at least one child" String
base) Cursor
cur)
                    else do
                      Expression
expr <- Cursor -> [String] -> IO Expression
xmirToExpression ([Cursor] -> Cursor
forall a. HasCallStack => [a] -> a
head [Cursor]
args) [String]
fqn
                      Attribute
attr <- String -> Cursor -> IO Attribute
toAttr String
rest Cursor
cur
                      let disp :: Expression
disp = Expression -> Attribute -> Expression
ExDispatch Expression
expr Attribute
attr
                      Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication Expression
disp ([Cursor] -> [Cursor]
forall a. HasCallStack => [a] -> [a]
tail [Cursor]
args) [String]
fqn
        String
"$" ->
          if [Cursor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Cursor
cur Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o"))
            then Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
ExThis
            else XMIRException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Application of '$' is illegal in XMIR" Cursor
cur)
        String
"Q" ->
          if [Cursor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Cursor
cur Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o"))
            then Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
ExGlobal
            else XMIRException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Application of 'Q' is illegal in XMIR" Cursor
cur)
        Char
'Q' : Char
'.' : String
rest -> Expression
-> String -> String -> Cursor -> [String] -> IO Expression
xmirToExpression' Expression
ExGlobal String
"Q" String
rest Cursor
cur [String]
fqn
        Char
'$' : Char
'.' : String
rest -> Expression
-> String -> String -> Cursor -> [String] -> IO Expression
xmirToExpression' Expression
ExThis String
"$" String
rest Cursor
cur [String]
fqn
        String
_ -> XMIRException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"The @base attribute must be either ['∅'|'Q'] or start with ['Q.'|'$.'|'.']" Cursor
cur)
  | Bool
otherwise = do
      [Binding]
bds <- (Cursor -> IO Binding) -> [Cursor] -> IO [Binding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Cursor -> [String] -> IO Binding
`xmirToFormationBinding` [String]
fqn) (Cursor
cur Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o"))
      Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding] -> Expression
ExFormation ([Binding] -> [Binding]
withVoidRho [Binding]
bds))
  where
    xmirToExpression' :: Expression -> String -> String -> C.Cursor -> [String] -> IO Expression
    xmirToExpression' :: Expression
-> String -> String -> Cursor -> [String] -> IO Expression
xmirToExpression' Expression
start String
symbol String
rest Cursor
cur [String]
fqn =
      if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest
        then XMIRException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"The @base='%s.' is illegal in XMIR" String
symbol) Cursor
cur)
        else do
          Expression
head' <-
            (Expression -> Text -> IO Expression)
-> Expression -> [Text] -> IO Expression
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
              (\Expression
acc Text
part -> Expression -> Attribute -> Expression
ExDispatch Expression
acc (Attribute -> Expression) -> IO Attribute -> IO Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Cursor -> IO Attribute
toAttr (Text -> String
T.unpack Text
part) Cursor
cur)
              Expression
start
              (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." (String -> Text
T.pack String
rest))
          let args :: [Cursor]
args = Cursor
cur Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o")
          Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication Expression
head' [Cursor]
args [String]
fqn

xmirToApplication :: Expression -> [C.Cursor] -> [String] -> IO Expression
xmirToApplication :: Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication = Integer -> Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication' Integer
0
  where
    xmirToApplication' :: Integer -> Expression -> [C.Cursor] -> [String] -> IO Expression
    xmirToApplication' :: Integer -> Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication' Integer
_ Expression
expr [] [String]
_ = Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
expr
    xmirToApplication' Integer
idx Expression
expr (Cursor
arg : [Cursor]
args) [String]
fqn = do
      let app :: IO Expression
app
            | String -> Cursor -> Bool
hasAttr String
"name" Cursor
arg = XMIRException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Application argument can't have @name attribute" Cursor
arg)
            | String -> Cursor -> Bool
hasAttr String
"base" Cursor
arg Bool -> Bool -> Bool
&& Cursor -> Bool
hasText Cursor
arg = XMIRException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"It's illegal in XMIR to have @base and text() at the same time" Cursor
arg)
            | Bool -> Bool
not (String -> Cursor -> Bool
hasAttr String
"base" Cursor
arg) Bool -> Bool -> Bool
&& Bool -> Bool
not (Cursor -> Bool
hasText Cursor
arg) = do
                [Binding]
bds <- (Cursor -> IO Binding) -> [Cursor] -> IO [Binding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Cursor -> [String] -> IO Binding
`xmirToFormationBinding` [String]
fqn) (Cursor
arg Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o"))
                Attribute
as <- Cursor -> Integer -> IO Attribute
asToAttr Cursor
arg Integer
idx
                Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Binding -> Expression
ExApplication Expression
expr (Attribute -> Expression -> Binding
BiTau Attribute
as ([Binding] -> Expression
ExFormation ([Binding] -> [Binding]
withVoidRho [Binding]
bds))))
            | Bool -> Bool
not (String -> Cursor -> Bool
hasAttr String
"base" Cursor
arg) Bool -> Bool -> Bool
&& Cursor -> Bool
hasText Cursor
arg = do
                Attribute
as <- Cursor -> Integer -> IO Attribute
asToAttr Cursor
arg Integer
idx
                String
text <- Cursor -> IO String
getText Cursor
arg
                Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Binding -> Expression
ExApplication Expression
expr (Attribute -> Expression -> Binding
BiTau Attribute
as ([Binding] -> Expression
ExFormation [String -> Binding
BiDelta String
text, Attribute -> Binding
BiVoid Attribute
AtRho])))
            | Bool
otherwise = do
                Attribute
as <- Cursor -> Integer -> IO Attribute
asToAttr Cursor
arg Integer
idx
                Expression
arg' <- Cursor -> [String] -> IO Expression
xmirToExpression Cursor
arg [String]
fqn
                Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Binding -> Expression
ExApplication Expression
expr (Attribute -> Expression -> Binding
BiTau Attribute
as Expression
arg'))
      Expression
app' <- IO Expression
app
      Integer -> Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication' (Integer
idx Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Expression
app' [Cursor]
args [String]
fqn

    asToAttr :: C.Cursor -> Integer -> IO Attribute
    asToAttr :: Cursor -> Integer -> IO Attribute
asToAttr Cursor
cur Integer
idx
      | String -> Cursor -> Bool
hasAttr String
"as" Cursor
cur = do
          String
as <- String -> Cursor -> IO String
getAttr String
"as" Cursor
cur
          Attribute
attr <- String -> Cursor -> IO Attribute
toAttr String
as Cursor
cur
          case Attribute
attr of
            Attribute
AtRho -> XMIRException -> IO Attribute
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"The '^' in @as attribute is illegal in XMIR" Cursor
cur)
            Attribute
other -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
other
      | Bool
otherwise = Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Attribute
AtAlpha Integer
idx)

toAttr :: String -> C.Cursor -> IO Attribute
toAttr :: String -> Cursor -> IO Attribute
toAttr String
attr Cursor
cur = case String
attr of
  Char
'α' : String
rest' ->
    case String -> Maybe Integer
forall a. Read a => String -> Maybe a
TR.readMaybe String
rest' :: Maybe Integer of
      Just Integer
idx -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Attribute
AtAlpha Integer
idx)
      Maybe Integer
Nothing -> XMIRException -> IO Attribute
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"The attribute started with 'α' must be followed by integer" Cursor
cur)
  String
"@" -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
AtPhi
  String
"^" -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
AtRho
  String
_
    | String -> Char
forall a. HasCallStack => [a] -> a
head String
attr Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'a' .. Char
'z'] -> XMIRException -> IO Attribute
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"The attribute '%s' must start with ['a'..'z']" String
attr) Cursor
cur)
    | Char
'.' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
attr -> XMIRException -> IO Attribute
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Attribute can't contain dots" Cursor
cur)
    | Bool
otherwise -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Attribute
AtLabel String
attr)

hasAttr :: String -> C.Cursor -> Bool
hasAttr :: String -> Cursor -> Bool
hasAttr String
key Cursor
cur = Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Name -> Cursor -> [Text]
C.attribute (String -> Name
toName String
key) Cursor
cur))

getAttr :: String -> C.Cursor -> IO String
getAttr :: String -> Cursor -> IO String
getAttr String
key Cursor
cur =
  let attrs :: [Text]
attrs = Name -> Cursor -> [Text]
C.attribute (String -> Name
toName String
key) Cursor
cur
   in if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
attrs
        then XMIRException -> IO String
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Couldn't find attribute '%s'" String
key) Cursor
cur)
        else
          let attr :: String
attr = (Text -> String
T.unpack (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. HasCallStack => [a] -> a
head) [Text]
attrs
           in if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
attr
                then XMIRException -> IO String
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"The attribute '%s' is not expected to be empty" String
attr) Cursor
cur)
                else String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
attr

hasText :: C.Cursor -> Bool
hasText :: Cursor -> Bool
hasText Cursor
cur = (Cursor -> Bool) -> [Cursor] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Cursor -> Bool
isNonEmptyTextNode (Cursor -> [Cursor]
forall node. Cursor node -> [Cursor node]
C.child Cursor
cur)
  where
    isNonEmptyTextNode :: Cursor -> Bool
isNonEmptyTextNode Cursor
cur' = case Cursor -> Node
forall node. Cursor node -> node
C.node Cursor
cur' of
      NodeContent Text
t -> Bool -> Bool
not (Text -> Bool
T.null (Text -> Text
T.strip Text
t)) -- strip to ignore whitespace-only
      Node
_ -> Bool
False

getText :: C.Cursor -> IO String
getText :: Cursor -> IO String
getText Cursor
cur =
  case [Text
t | Cursor
c <- Cursor -> [Cursor]
forall node. Cursor node -> [Cursor node]
C.child Cursor
cur, NodeContent Text
t <- [Cursor -> Node
forall node. Cursor node -> node
C.node Cursor
c]] of
    (Text
t : [Text]
_) -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
T.unpack Text
t)
    [] -> XMIRException -> IO String
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Text content inside <o> element can't be empty" Cursor
cur)