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

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

module XMIR
  ( expressionToXMIR
  , printXMIR
  , toName
  , parseXMIR
  , parseXMIRThrows
  , xmirToPhi
  , xmirAtoms
  , renameAtoms
  , Atoms
  , defaultXmirContext
  , escapeXML
  , escapeXMLText
  , gitRevision
  , xmirTime
  , XmirContext (XmirContext)
  )
where

import AST
import Bytes (btsIsUtf8, btsSize, btsToNum, btsToStr, bytesToBts)
import Control.Exception (Exception (displayException), throwIO)
import Control.Monad (unless, when)
import Data.Bifunctor (bimap)
import Data.Char (isAsciiLower, isDigit)
import Data.Foldable (foldlM)
import Data.List (find, groupBy, intercalate, nub)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import Data.Time (UTCTime (utctDayTime), diffTimeToPicoseconds, diffUTCTime, getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Version (showVersion)
import Development.GitRev (gitHash)
import Misc
import Parser (parseAttribute)
import Paths_phino (version)
import Printer
import Text.Printf (printf)
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 -> Bool
_hideRho :: Bool
  , XmirContext -> Expression -> String
_listing :: Expression -> String
  , XmirContext -> Atoms
_atoms :: Atoms
  }

type Atoms = M.Map T.Text String

gitRevision :: String
gitRevision :: String
gitRevision = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
7 $(gitHash)

defaultXmirContext :: XmirContext
defaultXmirContext :: XmirContext
defaultXmirContext = Bool
-> Bool -> Bool -> (Expression -> String) -> Atoms -> XmirContext
XmirContext Bool
True Bool
True Bool
False (String -> Expression -> String
forall a b. a -> b -> a
const String
"") Atoms
forall k a. Map k a
M.empty

data XMIRException
  = UnsupportedTopExpression Expression
  | UnsupportedExpression Expression
  | UnsupportedBinding Binding
  | CouldNotParseXMIR String
  | InvalidXMIRFormat String 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 (UnsupportedTopExpression Expression
expr) = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"XMIR does not support such top-level expression:\n%s" (Expression -> String
printExpression Expression
expr)
  show (UnsupportedExpression Expression
expr) = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"XMIR does not support such expression:\n%s" (Expression -> String
printExpression Expression
expr)
  show (UnsupportedBinding Binding
bd) = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"XMIR does not support such bindings: %s" (Binding -> String
printBinding Binding
bd)
  show (CouldNotParseXMIR String
msg) = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Couldn't parse given XMIR, cause: %s" String
msg
  show (InvalidXMIRFormat String
msg Cursor
cur) =
    String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
      String
"Couldn't traverse though given XMIR, cause: %s\nXMIR:\n%s"
      String
msg
      ( case Cursor -> Node
forall node. Cursor node -> node
C.node Cursor
cur 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 =
  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
bimap String -> Name
toName String -> Text
T.pack) [(String, String)]
attrs)
   in 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
ExXi XmirContext
_ = (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> String
printExpression Expression
ExXi, [])
expression Expression
ExRoot XmirContext
_ = (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> String
printExpression Expression
ExRoot, [])
expression Expression
ExTermination XmirContext
_ = (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"⊥", [])
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
printAttribute Attribute
attr
  case String
base of
    [] -> (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])
    Char
ch : String
_ ->
      if Char
ch 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 (DataNumber Bytes
bytes) XmirContext{Bool
Atoms
Expression -> String
_omitListing :: XmirContext -> Bool
_omitComments :: XmirContext -> Bool
_hideRho :: XmirContext -> Bool
_listing :: XmirContext -> Expression -> String
_atoms :: XmirContext -> Atoms
_omitListing :: Bool
_omitComments :: Bool
_hideRho :: Bool
_listing :: Expression -> String
_atoms :: Atoms
..} =
  let bts :: Node
bts =
        [(String, String)] -> [Node] -> Node
object
          [(String
"as", String
"φ"), (String
"base", String
"Φ.bytes")]
          [[(String, String)] -> [Node] -> Node
object [(String
"as", String
"φ")] [Text -> Node
NodeContent (String -> Text
T.pack (Bytes -> String
printBytes Bytes
bytes))]]
   in (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( String
"Φ.number"
        , if Bool
_omitComments Bool -> Bool -> Bool
|| Bytes -> Int
btsSize Bytes
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
8
            then [Node
bts]
            else
              [ Text -> Node
NodeComment (String -> Text
T.pack (Double -> String
forall a. Show a => a -> String
show (Bytes -> Double
btsToNum Bytes
bytes)))
              , Node
bts
              ]
        )
expression (DataString Bytes
bytes) XmirContext{Bool
Atoms
Expression -> String
_omitListing :: XmirContext -> Bool
_omitComments :: XmirContext -> Bool
_hideRho :: XmirContext -> Bool
_listing :: XmirContext -> Expression -> String
_atoms :: XmirContext -> Atoms
_omitListing :: Bool
_omitComments :: Bool
_hideRho :: Bool
_listing :: Expression -> String
_atoms :: Atoms
..} =
  let bts :: Node
bts =
        [(String, String)] -> [Node] -> Node
object
          [(String
"as", String
"φ"), (String
"base", String
"Φ.bytes")]
          [[(String, String)] -> [Node] -> Node
object [(String
"as", String
"φ")] [Text -> Node
NodeContent (String -> Text
T.pack (Bytes -> String
printBytes Bytes
bytes))]]
   in (String, [Node]) -> IO (String, [Node])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( String
"Φ.string"
        , if Bool
_omitComments Bool -> Bool -> Bool
|| Bool -> Bool
not (Bytes -> Bool
btsIsUtf8 Bytes
bytes)
            then [Node
bts]
            else
              [ Text -> Node
NodeComment (String -> Text
T.pack (Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
: Bytes -> String
btsToStr Bytes
bytes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""))
              , Node
bts
              ]
        )
expression app :: Expression
app@(ExApplication Expression
expr (ArTau Attribute
AtRho Expression
_)) ctx :: XmirContext
ctx@XmirContext{Bool
Atoms
Expression -> String
_omitListing :: XmirContext -> Bool
_omitComments :: XmirContext -> Bool
_hideRho :: XmirContext -> Bool
_listing :: XmirContext -> Expression -> String
_atoms :: XmirContext -> Atoms
_omitListing :: Bool
_omitComments :: Bool
_hideRho :: Bool
_listing :: Expression -> String
_atoms :: Atoms
..}
  | Bool
_hideRho = Expression -> XmirContext -> IO (String, [Node])
expression Expression
expr XmirContext
ctx
  | Bool
otherwise = XMIRException -> IO (String, [Node])
forall e a. Exception e => e -> IO a
throwIO (Expression -> XMIRException
UnsupportedExpression Expression
app)
expression app :: Expression
app@(ExApplication Expression
expr Argument
arg) XmirContext
ctx = do
  (String
base, [Node]
children) <- Expression -> XmirContext -> IO (String, [Node])
expression Expression
expr XmirContext
ctx
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
base) (XMIRException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (Expression -> XMIRException
UnsupportedExpression Expression
app))
  (String
base', [Node]
children') <- Expression -> XmirContext -> IO (String, [Node])
expression Expression
texpr XmirContext
ctx
  let 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'])
  where
    (String
as, Expression
texpr) = case Argument
arg of
      ArTau Attribute
attr Expression
value -> (Attribute -> String
printAttribute Attribute
attr, Expression
value)
      ArAlpha Alpha
alpha Expression
value -> (Alpha -> String
printAlpha Alpha
alpha, Expression
value)
expression Expression
expr XmirContext
_ = XMIRException -> IO (String, [Node])
forall e a. Exception e => e -> IO a
throwIO (Expression -> XMIRException
UnsupportedExpression Expression
expr)

formationBinding :: Binding -> XmirContext -> IO (Maybe Node)
formationBinding :: Binding -> XmirContext -> IO (Maybe Node)
formationBinding (BiTau (AtLabel Text
label) Expression
expr) XmirContext
ctx = Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> IO Node -> IO (Maybe Node)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Expression -> XmirContext -> IO Node
namedBinding (Text -> String
T.unpack Text
label) Expression
expr XmirContext
ctx
formationBinding (BiTau Attribute
AtRho Expression
expr) XmirContext
ctx = Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> IO Node -> IO (Maybe Node)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Expression -> XmirContext -> IO Node
namedBinding (Attribute -> String
forall a. Show a => a -> String
show Attribute
AtRho) Expression
expr XmirContext
ctx
formationBinding (BiTau Attribute
AtPhi Expression
expr) XmirContext
ctx = Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> IO Node -> IO (Maybe Node)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Expression -> XmirContext -> IO Node
namedBinding (Attribute -> String
forall a. Show a => a -> String
show Attribute
AtPhi) Expression
expr XmirContext
ctx
formationBinding (BiDelta Bytes
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 (Bytes -> String
printBytes Bytes
bytes))))
formationBinding (BiLambda (Function Text
name)) XmirContext{Bool
Atoms
Expression -> String
_omitListing :: XmirContext -> Bool
_omitComments :: XmirContext -> Bool
_hideRho :: XmirContext -> Bool
_listing :: XmirContext -> Expression -> String
_atoms :: XmirContext -> Atoms
_omitListing :: Bool
_omitComments :: Bool
_hideRho :: Bool
_listing :: Expression -> String
_atoms :: Atoms
..} =
  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, String)]
-> (String -> [(String, String)])
-> Maybe String
-> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
atom -> [(String
"atom", String
atom)]) (Text -> Atoms -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name Atoms
_atoms) [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String
"name", Attribute -> String
forall a. Show a => a -> String
show Attribute
AtLambda)]) [Text -> Node
NodeContent Text
name]))
formationBinding (BiVoid Attribute
AtRho) 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", Attribute -> String
forall a. Show a => a -> String
show Attribute
AtRho), (String
"base", String
"∅")] []))
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", Attribute -> String
forall a. Show a => a -> String
show Attribute
AtPhi), (String
"base", String
"∅")] []))
formationBinding (BiVoid (AtLabel Text
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", Text -> String
T.unpack Text
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)

namedBinding :: String -> Expression -> XmirContext -> IO Node
namedBinding :: String -> Expression -> XmirContext -> IO Node
namedBinding String
name (ExFormation [Binding]
bds) XmirContext
ctx = [(String, String)] -> [Node] -> Node
object [(String
"name", String
name)] ([Node] -> Node) -> IO [Node] -> IO Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding] -> XmirContext -> IO [Node]
nestedBindings [Binding]
bds XmirContext
ctx
namedBinding String
name Expression
expr XmirContext
ctx = do
  (String
base, [Node]
children) <- Expression -> XmirContext -> IO (String, [Node])
expression Expression
expr XmirContext
ctx
  Node -> IO Node
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(String, String)] -> [Node] -> Node
object [(String
"name", String
name), (String
"base", String
base)] [Node]
children)

nestedBindings :: [Binding] -> XmirContext -> IO [Node]
nestedBindings :: [Binding] -> XmirContext -> IO [Node]
nestedBindings [Binding]
bds ctx :: XmirContext
ctx@XmirContext{Bool
Atoms
Expression -> String
_omitListing :: XmirContext -> Bool
_omitComments :: XmirContext -> Bool
_hideRho :: XmirContext -> Bool
_listing :: XmirContext -> Expression -> String
_atoms :: XmirContext -> Atoms
_omitListing :: Bool
_omitComments :: Bool
_hideRho :: Bool
_listing :: Expression -> String
_atoms :: Atoms
..} = [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'
  where
    bds' :: [Binding]
    bds' :: [Binding]
bds' = if Bool
_hideRho then (Binding -> Bool) -> [Binding] -> [Binding]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Binding -> Bool) -> Binding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> Bool
isRho) [Binding]
bds else [Binding]
bds
    isRho :: Binding -> Bool
    isRho :: Binding -> Bool
isRho (BiTau Attribute
AtRho Expression
_) = Bool
True
    isRho (BiVoid Attribute
AtRho) = Bool
True
    isRho Binding
_ = Bool
False

expressionToXMIR :: Expression -> XmirContext -> IO Document
expressionToXMIR :: Expression -> XmirContext -> IO Document
expressionToXMIR expr :: Expression
expr@(ExFormation [Binding]
bds) XmirContext
ctx
  | [BiTau (AtLabel Text
_) Expression
arg] <- [Binding] -> [Binding]
withoutVoidRho [Binding]
bds = case Expression
arg of
      ExFormation [Binding]
_ -> Expression -> XmirContext -> IO Document
programToXMIR Expression
expr XmirContext
ctx
      ExApplication Expression
_ Argument
_ -> Expression -> XmirContext -> IO Document
programToXMIR Expression
expr XmirContext
ctx
      ExDispatch Expression
_ Attribute
_ -> Expression -> XmirContext -> IO Document
programToXMIR Expression
expr XmirContext
ctx
      Expression
ExRoot -> Expression -> XmirContext -> IO Document
programToXMIR Expression
expr XmirContext
ctx
      Expression
ExTermination -> Expression -> XmirContext -> IO Document
programToXMIR Expression
expr XmirContext
ctx
      Expression
ExXi -> Expression -> XmirContext -> IO Document
programToXMIR Expression
expr XmirContext
ctx
      Expression
_ -> XMIRException -> IO Document
forall e a. Exception e => e -> IO a
throwIO (Expression -> XMIRException
UnsupportedTopExpression Expression
expr)
expressionToXMIR expr :: Expression
expr@(ExFormation [Binding]
bds) XmirContext
ctx =
  XmirContext -> [String] -> Expression -> IO [Node] -> IO Document
documentWith XmirContext
ctx [] Expression
expr IO [Node]
rootNodes
  where
    rootNodes :: IO [Node]
    rootNodes :: IO [Node]
rootNodes = do
      [Node]
roots <- [Binding] -> XmirContext -> IO [Node]
nestedBindings [Binding]
bds XmirContext
ctx
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Node -> Bool) -> [Node] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node -> Bool
isElement [Node]
roots) (XMIRException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (Expression -> XMIRException
UnsupportedTopExpression Expression
expr))
      [Node] -> IO [Node]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[(String, String)] -> [Node] -> Node
object [] [Node]
roots]
    isElement :: Node -> Bool
    isElement :: Node -> Bool
isElement (NodeElement Element
_) = Bool
True
    isElement Node
_ = Bool
False
expressionToXMIR Expression
expr XmirContext
_ = XMIRException -> IO Document
forall e a. Exception e => e -> IO a
throwIO (Expression -> XMIRException
UnsupportedTopExpression Expression
expr)

withoutVoidRho :: [Binding] -> [Binding]
withoutVoidRho :: [Binding] -> [Binding]
withoutVoidRho = (Binding -> Bool) -> [Binding] -> [Binding]
forall a. (a -> Bool) -> [a] -> [a]
filter (Binding -> Binding -> Bool
forall a. Eq a => a -> a -> Bool
/= Attribute -> Binding
BiVoid Attribute
AtRho)

programToXMIR :: Expression -> XmirContext -> IO Document
programToXMIR :: Expression -> XmirContext -> IO Document
programToXMIR Expression
expr XmirContext
ctx = do
  ([String]
pckg, Expression
expr') <- Expression -> IO ([String], Expression)
getPackage Expression
expr
  XmirContext -> [String] -> Expression -> IO [Node] -> IO Document
documentWith XmirContext
ctx [String]
pckg Expression
expr (Expression -> XmirContext -> IO [Node]
rootNodes Expression
expr' XmirContext
ctx)
  where
    getPackage :: Expression -> IO ([String], Expression)
    getPackage :: Expression -> IO ([String], Expression)
getPackage ex :: Expression
ex@(ExFormation [Binding]
bds) = case [Binding] -> [Binding]
withoutVoidRho [Binding]
bds of
      [BiTau (AtLabel Text
label) inner :: Expression
inner@(ExFormation [Binding]
inner')] | [Binding] -> Bool
packaged [Binding]
inner' -> Text -> Expression -> IO ([String], Expression)
nested Text
label Expression
inner
      [BiTau (AtLabel Text
label) inner :: Expression
inner@(ExFormation [Binding]
inner'), BiLambda (Function Text
"Package")] | [Binding] -> Bool
packaged [Binding]
inner' -> Text -> Expression -> IO ([String], Expression)
nested Text
label Expression
inner
      [BiTau Attribute
at Expression
body, BiLambda (Function Text
"Package")] -> ([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
at Expression
body])
      [Binding
bd] -> ([String], Expression) -> IO ([String], Expression)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [Binding] -> Expression
ExFormation [Binding
bd])
      [Binding]
_ -> Expression -> IO ([String], Expression)
unpackaged Expression
ex
    getPackage Expression
ex = Expression -> IO ([String], Expression)
unpackaged Expression
ex
    nested :: T.Text -> Expression -> IO ([String], Expression)
    nested :: Text -> Expression -> IO ([String], Expression)
nested Text
label Expression
inner = do
      ([String]
pckg, Expression
expr') <- Expression -> IO ([String], Expression)
getPackage Expression
inner
      ([String], Expression) -> IO ([String], Expression)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
T.unpack Text
label String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
pckg, Expression
expr')
    packaged :: [Binding] -> Bool
    packaged :: [Binding] -> Bool
packaged [Binding]
bds = case [Binding] -> [Binding]
withoutVoidRho [Binding]
bds of
      [Binding
_, BiLambda (Function Text
"Package")] -> Bool
True
      [Binding]
_ -> Bool
False
    unpackaged :: Expression -> IO ([String], Expression)
    unpackaged :: Expression -> IO ([String], Expression)
unpackaged Expression
ex = 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
printExpression Expression
ex)))
    rootNodes :: Expression -> XmirContext -> IO [Node]
    rootNodes :: Expression -> XmirContext -> IO [Node]
rootNodes (ExFormation [Binding
bd]) XmirContext
c = [Binding] -> XmirContext -> IO [Node]
nestedBindings [Binding
bd] XmirContext
c
    rootNodes Expression
ex XmirContext
_ = XMIRException -> IO [Node]
forall e a. Exception e => e -> IO a
throwIO (Expression -> XMIRException
UnsupportedExpression Expression
ex)

documentWith :: XmirContext -> [String] -> Expression -> IO [Node] -> IO Document
documentWith :: XmirContext -> [String] -> Expression -> IO [Node] -> IO Document
documentWith XmirContext{Bool
Atoms
Expression -> String
_omitListing :: XmirContext -> Bool
_omitComments :: XmirContext -> Bool
_hideRho :: XmirContext -> Bool
_listing :: XmirContext -> Expression -> String
_atoms :: XmirContext -> Atoms
_omitListing :: Bool
_omitComments :: Bool
_hideRho :: Bool
_listing :: Expression -> String
_atoms :: Atoms
..} [String]
pckg Expression
expr IO [Node]
rootsIO = do
  UTCTime
started <- IO UTCTime
getCurrentTime
  [Node]
roots <- IO [Node]
rootsIO
  UTCTime
now <- IO UTCTime
getCurrentTime
  let text :: String
text = Expression -> String
_listing Expression
expr
      listing :: String
listing =
        if Bool
_omitListing
          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
text)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" line(s)"
          else String
text
      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)
      ms :: Int
      ms :: Int
ms = NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
started NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000)
      revisionAttr :: [(String, String)]
revisionAttr = [(String
"revision", String
gitRevision) | String
gitRevision String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"UNKNOWN"]
      attrs :: [(String, String)]
attrs =
        [ (String
"author", String
"phino")
        , (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", Int -> String
forall a. Show a => a -> String
show Int
ms)
        , (String
"time", UTCTime -> String
xmirTime 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")
        ]
          [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. Semigroup a => a -> a -> a
<> [(String, String)]
revisionAttr
  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, String)]
attrs
            ( if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
pckg
                then [Node
listing'] [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node]
roots
                else [Node
listing', Node
metas] [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node]
roots
            )
        )
        []
    )
  where
    metasWithPackage :: String -> Node
    metasWithPackage :: String -> Node
metasWithPackage String
package =
      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
package)])
                    , Element -> Node
NodeElement (String -> [(String, String)] -> [Node] -> Element
element String
"part" [] [Text -> Node
NodeContent (String -> Text
T.pack String
package)])
                    ]
                )
            ]
        )

xmirTime :: UTCTime -> String
xmirTime :: UTCTime -> String
xmirTime UTCTime
stamp =
  TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S" UTCTime
stamp
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
".%09dZ" ((DiffTime -> Integer
diffTimeToPicoseconds (UTCTime -> DiffTime
utctDayTime UTCTime
stamp) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1_000) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
1_000_000_000)

renameAtoms :: [(T.Text, T.Text)] -> XmirContext -> XmirContext
renameAtoms :: [(Text, Text)] -> XmirContext -> XmirContext
renameAtoms [(Text, Text)]
renames ctx :: XmirContext
ctx@XmirContext{Bool
Atoms
Expression -> String
_omitListing :: XmirContext -> Bool
_omitComments :: XmirContext -> Bool
_hideRho :: XmirContext -> Bool
_listing :: XmirContext -> Expression -> String
_atoms :: XmirContext -> Atoms
_omitListing :: Bool
_omitComments :: Bool
_hideRho :: Bool
_listing :: Expression -> String
_atoms :: Atoms
..} =
  XmirContext
ctx{_atoms = M.fromList [(new, atom) | (old, new) <- renames, Just atom <- [M.lookup old _atoms]]}

escapeXML :: String -> String
escapeXML :: String -> String
escapeXML = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeChar
  where
    escapeChar :: Char -> String
    escapeChar :: Char -> String
escapeChar Char
'&' = String
"&amp;"
    escapeChar Char
'<' = String
"&lt;"
    escapeChar Char
'>' = String
"&gt;"
    escapeChar Char
'"' = String
"&quot;"
    escapeChar Char
'\'' = String
"&apos;"
    escapeChar Char
ch = [Char
ch]

escapeXMLText :: String -> String
escapeXMLText :: String -> String
escapeXMLText = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeChar
  where
    escapeChar :: Char -> String
    escapeChar :: Char -> String
escapeChar Char
'&' = String
"&amp;"
    escapeChar Char
'<' = String
"&lt;"
    escapeChar Char
'>' = String
"&gt;"
    escapeChar Char
ch = [Char
ch]

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' :: Bool -> TB.Builder
newline' :: Bool -> Builder
newline' Bool
True = Builder
newline
newline' Bool
False = Builder
""

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

printElement :: Int -> Element -> Bool -> TB.Builder
printElement :: Int -> Element -> Bool -> Builder
printElement Int
indentLevel (Element Name
name Map Name Text
attrs [Node]
nodes) Bool
eol
  | [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
<> Bool -> Builder
newline' Bool
eol
  | (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
<> Bool -> Builder
newline' Bool
eol
  | 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
<> Bool -> Builder
newline' Bool
eol
  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 (String -> Text
T.pack (String -> String
escapeXML (Text -> String
T.unpack 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 :: Int -> Node -> TB.Builder
printNode :: Int -> Node -> Builder
printNode Int
_ (NodeContent Text
t) = Text -> Builder
TB.fromText Text
t
printNode Int
i (NodeElement Element
e) = Int -> Element -> Bool -> Builder
printElement Int
i Element
e Bool
True
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 -> Bool -> Builder
printElement Int
0 Element
root Bool
False
        )
    )

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 = (String -> XMIRException) -> Either String Document -> IO Document
forall e a. Exception e => (String -> e) -> Either String a -> IO a
orThrow String -> XMIRException
CouldNotParseXMIR (String -> Either String Document
parseXMIR String
xmir)

strayNodes :: C.Cursor -> [Node]
strayNodes :: Cursor -> [Node]
strayNodes Cursor
doc = (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter Node -> Bool
bad ((Cursor -> Node) -> [Cursor] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Cursor -> Node
forall node. Cursor node -> node
C.node (Cursor -> [Cursor]
forall node. Cursor node -> [Cursor node]
C.child Cursor
doc))
  where
    bad :: Node -> Bool
    bad :: Node -> Bool
bad (NodeInstruction Instruction
_) = Bool
True
    bad (NodeContent Text
t) = Bool -> Bool
not (Text -> Bool
T.null (Text -> Text
T.strip Text
t))
    bad Node
_ = Bool
False

xmirToPhi :: Document -> IO Expression
xmirToPhi :: Document -> IO Expression
xmirToPhi Document
xmir =
  let doc :: Cursor
doc = Document -> Cursor
C.fromDocument Document
xmir
      derived :: Derived
derived = Document -> Derived
derivedNames 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
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Node] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Cursor -> [Node]
strayNodes Cursor
doc)) (XMIRException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"No processing instructions or bare text are allowed in <object>" Cursor
doc))
              Cursor
o <- 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
single] -> Cursor -> IO Cursor
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cursor
single
                [Cursor]
_ -> XMIRException -> IO Cursor
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Expected single <o> element in <object>" Cursor
doc)
              let packages :: [Cursor]
packages =
                    [ Cursor
meta
                    | 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"]
                    ]
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Cursor] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cursor]
packages Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (XMIRException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"A <metas> can hold only one package meta" Cursor
doc))
              let pckg :: [String]
pckg =
                    [ Text -> String
T.unpack Text
t
                    | Cursor
meta <- [Cursor]
packages
                    , 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 -> Text
T.strip Text
tail')
                    ]
              (String -> IO Attribute) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Cursor -> IO Attribute
`toAttr` Cursor
doc) [String]
pckg
              if Cursor -> Bool
bareRoot Cursor
o
                then
                  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
pckg
                    then Derived -> Cursor -> [String] -> IO Expression
xmirToFormation Derived
derived Cursor
o []
                    else XMIRException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"A <object> with <metas> package must hold a named <o>" Cursor
doc)
                else
                  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
pckg
                    then do
                      Binding
bd <- Derived -> Cursor -> [String] -> IO Binding
xmirToFormationBinding Derived
derived Cursor
o []
                      Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding] -> Expression
ExFormation [Binding
bd])
                    else do
                      Binding
obj <- Derived -> Cursor -> [String] -> IO Binding
xmirToFormationBinding Derived
derived Cursor
o []
                      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 (Text -> Attribute
AtLabel (String -> Text
T.pack String
part)) ([Binding] -> Expression
ExFormation [Binding
acc, Function -> Binding
BiLambda (Text -> Function
Function Text
"Package")])) Binding
obj [String]
pckg
                      Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding] -> Expression
ExFormation [Binding
bd])
          | Bool
otherwise -> XMIRException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"Expected single <object> element" Cursor
doc)
        Node
_ -> XMIRException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"NodeElement is expected as root element" Cursor
doc)

bareRoot :: C.Cursor -> Bool
bareRoot :: Cursor -> Bool
bareRoot Cursor
o = Bool -> Bool
not ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> Cursor -> Bool
`hasAttr` Cursor
o) [String
"name", String
"base", String
"as"])

xmirToFormationBinding :: Derived -> C.Cursor -> [String] -> IO Binding
xmirToFormationBinding :: Derived -> Cursor -> [String] -> IO Binding
xmirToFormationBinding Derived
derived 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
      case String
name of
        String
"λ" -> Function -> Binding
BiLambda (Function -> Binding) -> (Text -> Function) -> Text -> Binding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Function
Function (Text -> Binding) -> IO Text -> IO Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Derived -> Cursor -> [String] -> IO Text
lambdaName Derived
derived Cursor
cur [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
"φ" -> Attribute -> Expression -> Binding
BiTau Attribute
AtPhi (Expression -> Binding) -> IO Expression -> IO Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Derived -> Cursor -> [String] -> IO Expression
xmirToFormation Derived
derived Cursor
cur (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
fqn)
        String
"ρ" -> Attribute -> Expression -> Binding
BiTau Attribute
AtRho (Expression -> Binding) -> IO Expression -> IO Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Derived -> Cursor -> [String] -> IO Expression
xmirToFormation Derived
derived Cursor
cur (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
fqn)
        (Char
'+' : String
test) -> String -> Cursor -> IO Attribute
toAttr String
test Cursor
cur IO Attribute -> IO Binding -> IO Binding
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Attribute -> Expression -> Binding
BiTau (Text -> Attribute
AtLabel (String -> Text
T.pack String
name)) (Expression -> Binding) -> IO Expression -> IO Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Derived -> Cursor -> [String] -> IO Expression
xmirToFormation Derived
derived Cursor
cur (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
fqn)
        (Char
'-' : String
test) -> String -> Cursor -> IO Attribute
toAttr String
test Cursor
cur IO Attribute -> IO Binding -> IO Binding
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Attribute -> Expression -> Binding
BiTau (Text -> Attribute
AtLabel (String -> Text
T.pack String
name)) (Expression -> Binding) -> IO Expression -> IO Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Derived -> Cursor -> [String] -> IO Expression
xmirToFormation Derived
derived Cursor
cur (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
fqn)
        String
_ -> String -> Cursor -> IO Attribute
toAttr String
name Cursor
cur IO Attribute -> (Attribute -> IO Binding) -> IO Binding
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Attribute
attr -> Attribute -> Expression -> Binding
BiTau Attribute
attr (Expression -> Binding) -> IO Expression -> IO Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Derived -> Cursor -> [String] -> IO Expression
xmirToFormation Derived
derived Cursor
cur (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
fqn)
  | 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
        String
"ρ" -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
AtRho
        (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)
        (Char
'+' : String
test) -> String -> Cursor -> IO Attribute
toAttr String
test Cursor
cur IO Attribute -> IO Attribute -> IO Attribute
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Attribute
AtLabel (String -> Text
T.pack String
name))
        (Char
'-' : String
test) -> String -> Cursor -> IO Attribute
toAttr String
test Cursor
cur IO Attribute -> IO Attribute -> IO Attribute
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Attribute
AtLabel (String -> Text
T.pack String
name))
        String
_ -> String -> Cursor -> IO Attribute
toAttr String
name Cursor
cur
      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 <- Derived -> Cursor -> [String] -> IO Expression
xmirToExpression Derived
derived 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)

type Derived = M.Map [String] T.Text

lambdaName :: Derived -> C.Cursor -> [String] -> IO T.Text
lambdaName :: Derived -> Cursor -> [String] -> IO Text
lambdaName Derived
derived Cursor
cur [String]
fqn
  | Cursor -> Bool
hasText Cursor
cur = Text -> Text
T.strip (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cursor -> IO String
getText Cursor
cur
  | Bool
otherwise = Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [String] -> Derived -> Text
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([String] -> Text
spelled [String]
fqn) [String]
fqn Derived
derived)

spelled :: [String] -> T.Text
spelled :: [String] -> Text
spelled [String]
fqn = String -> Text
T.pack (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" (String
"L" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
spell) ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
fqn)))
  where
    spell :: Char -> Char
    spell :: Char -> Char
spell Char
ch = if Char -> Bool
isDigit Char
ch Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
ch Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'φ' then Char
ch else Char
'_'

derivedNames :: Document -> Derived
derivedNames :: Document -> Derived
derivedNames Document
xmir = ([Text], Derived) -> Derived
forall a b. (a, b) -> b
snd ((([Text], Derived) -> [String] -> ([Text], Derived))
-> ([Text], Derived) -> [[String]] -> ([Text], Derived)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([Text], Derived) -> [String] -> ([Text], Derived)
assign ([], Derived
forall k a. Map k a
M.empty) [[String]]
paths)
  where
    paths :: [[String]]
    paths :: [[String]]
paths =
      [[String]] -> [[String]]
forall a. Eq a => [a] -> [a]
nub
        [ Cursor -> [String]
lambdaPath Cursor
cur
        | Cursor
cur <- Document -> Cursor
C.fromDocument Document
xmir Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$// Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o") (Cursor -> [Cursor]) -> (Cursor -> [Cursor]) -> Cursor -> [Cursor]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
C.>=> Name -> Text -> Cursor -> [Cursor]
C.attributeIs (String -> Name
toName String
"name") Text
"λ"
        , Bool -> Bool
not (Cursor -> Bool
hasText Cursor
cur)
        ]
    bases :: [T.Text]
    bases :: [Text]
bases = ([String] -> Text) -> [[String]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> Text
spelled [[String]]
paths
    assign :: ([T.Text], Derived) -> [String] -> ([T.Text], Derived)
    assign :: ([Text], Derived) -> [String] -> ([Text], Derived)
assign ([Text]
used, Derived
names) [String]
path =
      let base :: Text
base = [String] -> Text
spelled [String]
path
          name :: Text
name = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
base ((Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Text
candidate -> Text
candidate Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
used Bool -> Bool -> Bool
&& (Text
candidate Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
base Bool -> Bool -> Bool
|| Text
candidate Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
bases)) (Text
base Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
n) | Int
n <- [Int
2 :: Int ..]]))
       in (Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
used, [String] -> Text -> Derived -> Derived
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [String]
path Text
name Derived
names)

lambdaPath :: C.Cursor -> [String]
lambdaPath :: Cursor -> [String]
lambdaPath Cursor
cur =
  [ Text -> String
T.unpack Text
label
  | Cursor
enclosing <- Cursor
cur Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> a) -> a
C.$| (Cursor -> [Cursor]
forall node. Cursor node -> [Cursor node]
C.ancestor (Cursor -> [Cursor]) -> (Cursor -> [Cursor]) -> Cursor -> [Cursor]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
C.>=> Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o"))
  , Bool -> Bool
not (String -> Cursor -> Bool
hasAttr String
"base" Cursor
enclosing)
  , Bool -> Bool
not (String -> Cursor -> Bool
hasAttr String
"as" Cursor
enclosing)
  , Text
label <- Name -> Cursor -> [Text]
C.attribute (String -> Name
toName String
"name") Cursor
enclosing
  ]

xmirAtoms :: Document -> IO Atoms
xmirAtoms :: Document -> IO Atoms
xmirAtoms Document
xmir = [(Text, String)] -> Atoms
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, String)] -> Atoms) -> IO [(Text, String)] -> IO Atoms
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Cursor -> IO (Text, String)) -> [Cursor] -> IO [(Text, String)]
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 -> IO (Text, String)
entry [Cursor]
markers
  where
    markers :: [C.Cursor]
    markers :: [Cursor]
markers =
      Document -> Cursor
C.fromDocument Document
xmir
        Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$// Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o")
        (Cursor -> [Cursor]) -> (Cursor -> [Cursor]) -> Cursor -> [Cursor]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
C.>=> Name -> Text -> Cursor -> [Cursor]
C.attributeIs (String -> Name
toName String
"name") Text
"λ"
        (Cursor -> [Cursor]) -> (Cursor -> [Cursor]) -> Cursor -> [Cursor]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
C.>=> (Cursor -> Bool) -> Cursor -> [Cursor]
forall b. Boolean b => (Cursor -> b) -> Cursor -> [Cursor]
C.check (String -> Cursor -> Bool
hasAttr String
"atom")
    derived :: Derived
    derived :: Derived
derived = Document -> Derived
derivedNames Document
xmir
    entry :: C.Cursor -> IO (T.Text, String)
    entry :: Cursor -> IO (Text, String)
entry Cursor
cur = do
      Text
name <- Derived -> Cursor -> [String] -> IO Text
lambdaName Derived
derived Cursor
cur (Cursor -> [String]
lambdaPath Cursor
cur)
      String
atom <- String -> Cursor -> IO String
getAttr String
"atom" Cursor
cur
      (Text, String) -> IO (Text, String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
name, String
atom)

xmirToFormation :: Derived -> C.Cursor -> [String] -> IO Expression
xmirToFormation :: Derived -> Cursor -> [String] -> IO Expression
xmirToFormation Derived
derived Cursor
cur [String]
fqn = do
  [Binding]
bds <- [[Binding]] -> [Binding]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Binding]] -> [Binding]) -> IO [[Binding]] -> IO [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([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] -> IO [Binding]
binding ((Cursor -> Cursor -> Bool) -> [Cursor] -> [[Cursor]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\Cursor
left Cursor
right -> Bool -> Bool
not (Cursor -> Bool
nested Cursor
left) Bool -> Bool -> Bool
&& Bool -> Bool
not (Cursor -> Bool
nested Cursor
right)) (Cursor -> [Cursor]
forall node. Cursor node -> [Cursor node]
C.child Cursor
cur))
  [Binding] -> Expression
ExFormation ([Binding] -> Expression) -> IO [Binding] -> IO Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding] -> IO [Binding]
uniqueBindings' [Binding]
bds
  where
    nested :: C.Cursor -> Bool
    nested :: Cursor -> Bool
nested Cursor
node = Bool -> Bool
not ([Cursor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o") Cursor
node))
    binding :: [C.Cursor] -> IO [Binding]
    binding :: [Cursor] -> IO [Binding]
binding [Cursor
node] | Cursor -> Bool
nested Cursor
node = Binding -> [Binding]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding -> [Binding]) -> IO Binding -> IO [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Derived -> Cursor -> [String] -> IO Binding
xmirToFormationBinding Derived
derived Cursor
node [String]
fqn
    binding [Cursor]
nodes = [Binding] -> IO [Binding]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Bytes -> Binding
BiDelta (String -> Bytes
bytesToBts (Text -> String
T.unpack Text
text)) | Bool -> Bool
not (Text -> Bool
T.null Text
text)]
      where
        text :: T.Text
        text :: Text
text = Text -> Text
T.strip ([Text] -> Text
T.concat [Text
content | NodeContent Text
content <- (Cursor -> Node) -> [Cursor] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Cursor -> Node
forall node. Cursor node -> node
C.node [Cursor]
nodes])

xmirToExpression :: Derived -> C.Cursor -> [String] -> IO Expression
xmirToExpression :: Derived -> Cursor -> [String] -> IO Expression
xmirToExpression Derived
derived 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 case [Cursor]
args of
                    [] -> 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)
                    Cursor
arg : [Cursor]
args' -> do
                      Expression
expr <- Derived -> Cursor -> [String] -> IO Expression
xmirToExpression Derived
derived Cursor
arg [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
                      Derived -> Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication Derived
derived Expression
disp [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
ExXi
            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
"Φ" ->
          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
ExRoot
            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
"⊥" -> Derived -> Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication Derived
derived Expression
ExTermination (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")) [String]
fqn
        Char
'⊥' : Char
'.' : String
rest -> Expression
-> String -> String -> Cursor -> [String] -> IO Expression
xmirToExpression' Expression
ExTermination String
"⊥" String
rest Cursor
cur [String]
fqn
        Char
'Φ' : Char
'.' : String
rest -> Expression
-> String -> String -> Cursor -> [String] -> IO Expression
xmirToExpression' Expression
ExRoot String
"Φ" String
rest Cursor
cur [String]
fqn
        Char
'ξ' : Char
'.' : String
rest -> Expression
-> String -> String -> Cursor -> [String] -> IO Expression
xmirToExpression' Expression
ExXi 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 ['∅'|'Φ'] or start with ['Φ.'|'ξ.'|'.']" Cursor
cur)
  | Bool
otherwise = Derived -> Cursor -> [String] -> IO Expression
xmirToFormation Derived
derived Cursor
cur [String]
fqn
  where
    xmirToExpression' :: Expression -> String -> String -> C.Cursor -> [String] -> IO Expression
    xmirToExpression' :: Expression
-> String -> String -> Cursor -> [String] -> IO Expression
xmirToExpression' Expression
start String
symbol String
rst Cursor
c [String]
names =
      if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rst
        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
c)
        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
c)
              Expression
start
              (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." (String -> Text
T.pack String
rst))
          Derived -> Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication Derived
derived Expression
head' (Cursor
c Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
C.$/ Name -> Cursor -> [Cursor]
C.element (String -> Name
toName String
"o")) [String]
names

xmirToApplication :: Derived -> Expression -> [C.Cursor] -> [String] -> IO Expression
xmirToApplication :: Derived -> Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication Derived
derived = Int -> Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication' Int
0
  where
    xmirToApplication' :: Int -> Expression -> [C.Cursor] -> [String] -> IO Expression
    xmirToApplication' :: Int -> Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication' Int
_ Expression
expr [] [String]
_ = Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
expr
    xmirToApplication' Int
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) = do
                Either Alpha Attribute
key <- Cursor -> Int -> IO (Either Alpha Attribute)
asToKey Cursor
arg Int
idx
                Expression
arg' <- Derived -> Cursor -> [String] -> IO Expression
xmirToFormation Derived
derived Cursor
arg [String]
fqn
                Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Argument -> Expression
ExApplication Expression
expr (Either Alpha Attribute -> Expression -> Argument
mkArg Either Alpha Attribute
key Expression
arg'))
            | Bool
otherwise = do
                Either Alpha Attribute
key <- Cursor -> Int -> IO (Either Alpha Attribute)
asToKey Cursor
arg Int
idx
                Expression
arg' <- Derived -> Cursor -> [String] -> IO Expression
xmirToExpression Derived
derived Cursor
arg [String]
fqn
                Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Argument -> Expression
ExApplication Expression
expr (Either Alpha Attribute -> Expression -> Argument
mkArg Either Alpha Attribute
key Expression
arg'))
      Expression
app' <- IO Expression
app
      Int -> Expression -> [Cursor] -> [String] -> IO Expression
xmirToApplication' (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Expression
app' [Cursor]
args [String]
fqn
    mkArg :: Either Alpha Attribute -> Expression -> Argument
    mkArg :: Either Alpha Attribute -> Expression -> Argument
mkArg (Left Alpha
alpha) Expression
expr = Alpha -> Expression -> Argument
ArAlpha Alpha
alpha Expression
expr
    mkArg (Right Attribute
attr) Expression
expr = Attribute -> Expression -> Argument
ArTau Attribute
attr Expression
expr
    asToKey :: C.Cursor -> Int -> IO (Either Alpha Attribute)
    asToKey :: Cursor -> Int -> IO (Either Alpha Attribute)
asToKey Cursor
cur Int
position
      | String -> Cursor -> Bool
hasAttr String
"as" Cursor
cur = do
          String
as <- String -> Cursor -> IO String
getAttr String
"as" Cursor
cur
          case String
as 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
                | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
rest' Bool -> Bool -> Bool
&& Integer
idx Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int) -> Either Alpha Attribute -> IO (Either Alpha Attribute)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Alpha -> Either Alpha Attribute
forall a b. a -> Either a b
Left (Int -> Alpha
Alpha (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
idx)))
              Maybe Integer
_ -> XMIRException -> IO (Either Alpha Attribute)
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"The attribute started with 'α' must be followed by a non-negative integer that fits into %d" (Int
forall a. Bounded a => a
maxBound :: Int)) Cursor
cur)
            String
"ρ" -> XMIRException -> IO (Either Alpha 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)
            String
_ -> Attribute -> Either Alpha Attribute
forall a b. b -> Either a b
Right (Attribute -> Either Alpha Attribute)
-> IO Attribute -> IO (Either Alpha Attribute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Cursor -> IO Attribute
toAttr String
as Cursor
cur
      | Bool
otherwise = Either Alpha Attribute -> IO (Either Alpha Attribute)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Alpha -> Either Alpha Attribute
forall a b. a -> Either a b
Left (Int -> Alpha
Alpha Int
position))

toAttr :: String -> C.Cursor -> IO Attribute
toAttr :: String -> Cursor -> IO Attribute
toAttr String
attr Cursor
cur = case String
attr of
  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
  Char
'α' : String
_ -> XMIRException -> IO Attribute
forall e a. Exception e => e -> IO a
throwIO (String -> Cursor -> XMIRException
InvalidXMIRFormat String
"α-index is not a valid dispatch attribute in XMIR" Cursor
cur)
  Char
ch : String
_
    | Char
ch 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)
    | String -> Either String Attribute
parseAttribute String
attr Either String Attribute -> Either String Attribute -> Bool
forall a. Eq a => a -> a -> Bool
/= Attribute -> Either String Attribute
forall a b. b -> Either a b
Right (Text -> Attribute
AtLabel (String -> Text
T.pack String
attr)) -> 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' is not a label the phi grammar reads" String
attr) Cursor
cur)
    | Bool
otherwise -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Attribute
AtLabel (String -> Text
T.pack String
attr))
  String
_ -> 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
"Invalid attribute given: %s" String
attr) Cursor
cur)

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 case [Text]
attrs of
        [] -> 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)
        Text
at : [Text]
_ ->
          let attr :: String
attr = Text -> String
T.unpack Text
at
           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
key) 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))
      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
    [] -> 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)
    [Text]
texts -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
T.unpack ([Text] -> Text
T.concat [Text]
texts))