phino 0.0.0.59 → 0.0.0.60
raw patch · 19 files changed
+567/−682 lines, 19 files
Files
- README.md +2/−2
- phino.cabal +3/−1
- src/CLI.hs +38/−18
- src/CST.hs +74/−115
- src/Canonizer.hs +3/−0
- src/Encoding.hs +2/−2
- src/LaTeX.hs +22/−13
- src/Lining.hs +2/−2
- src/Logger.hs +4/−8
- src/Margin.hs +115/−0
- src/Printer.hs +13/−12
- src/Render.hs +5/−6
- src/Sugar.hs +21/−21
- src/XMIR.hs +6/−6
- test/CLISpec.hs +61/−70
- test/CSTSpec.hs +4/−3
- test/FilterSpec.hs +25/−216
- test/PrinterSpec.hs +10/−139
- test/XMIRSpec.hs +157/−48
README.md view
@@ -29,7 +29,7 @@ ```bash cabal update-cabal install --overwrite-policy=always phino-0.0.0.58+cabal install --overwrite-policy=always phino-0.0.0.59 phino --version ``` @@ -137,7 +137,7 @@ and print it in canonical syntax: ```bash-$ echo 'Q -> [[ @ -> QQ.io.stdout("hello") ]]' | phino rewrite+$ echo 'Q -> [[ @ -> Q.io.stdout("hello") ]]' | phino rewrite Φ ↦ ⟦ φ ↦ Φ.io.stdout( α0 ↦ Φ.string(
phino.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino-version: 0.0.0.59+version: 0.0.0.60 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -49,6 +49,7 @@ Lining Locator Logger+ Margin Matcher Merge Misc@@ -163,6 +164,7 @@ process ^>=1.6.19.0, silently ^>=1.2.5.4, text ^>=2.0.2,+ time ^>=1.12, xml-conduit ^>=1.10, yaml ^>=0.11.11.2,
src/CLI.hs view
@@ -25,10 +25,11 @@ import Encoding (Encoding (UNICODE)) import qualified Filter as F import Functions (buildTerm)-import LaTeX (LatexContext (LatexContext), explainRules, expressionToLaTeX, programToLaTeX, rewrittensToLatex)+import LaTeX (LatexContext (LatexContext), defaultMeetLength, defaultMeetPopularity, explainRules, expressionToLaTeX, programToLaTeX, rewrittensToLatex) import Lining (LineFormat (MULTILINE, SINGLELINE)) import Locator (locatedExpression) import Logger+import Margin (defaultMargin) import Merge (merge) import Misc (ensuredFile) import qualified Misc@@ -50,6 +51,7 @@ data PrintProgramContext = PrintProgCtx { _sugar :: SugarType , _line :: LineFormat+ , _margin :: Int , _xmirCtx :: XmirContext , _nonumber :: Bool , _compress :: Bool@@ -108,6 +110,7 @@ , _compress :: Bool , _maxDepth :: Int , _maxCycles :: Int+ , _margin :: Int , _meetPopularity :: Maybe Int , _meetLength :: Maybe Int , _hide :: [String]@@ -150,6 +153,7 @@ , _compress :: Bool , _maxDepth :: Int , _maxCycles :: Int+ , _margin :: Int , _meetPopularity :: Maybe Int , _meetLength :: Maybe Int , _rules :: [FilePath]@@ -174,6 +178,7 @@ , _flat :: LineFormat , _omitListing :: Bool , _omitComments :: Bool+ , _margin :: Int , _targetFile :: Maybe FilePath , _inputs :: [FilePath] }@@ -199,17 +204,14 @@ parseLogLevel ( long "log-level" <> metavar "LEVEL"- <> help ("Log level (" <> intercalate ", " (map show [DEBUG, INFO, WARNING, ERROR, NONE]) <> ")")- <> value INFO+ <> help ("Log level (" <> intercalate ", " (map show [DEBUG, ERROR, NONE]) <> ")")+ <> value ERROR <> showDefault ) where parseLogLevel :: ReadM LogLevel parseLogLevel = eitherReader $ \lvl -> case map toUpper lvl of "DEBUG" -> Right DEBUG- "INFO" -> Right INFO- "WARNING" -> Right WARNING- "WARN" -> Right WARNING "ERROR" -> Right ERROR "ERR" -> Right ERROR "NONE" -> Right NONE@@ -255,6 +257,12 @@ (auto >>= validateIntOption (> 0) "--max-cycles must be positive") (long "max-cycles" <> metavar "CYCLES" <> help "Maximum number of rewriting cycles across all rules" <> value 25 <> showDefault) +optMargin :: Parser Int+optMargin =+ option+ (auto >>= validateIntOption (> 0) "--margin must be positive")+ (long "margin" <> help "The maximum right margin for the printed 𝜑-programs or 𝜑-expressions" <> value defaultMargin <> showDefault)+ optMeetPopularity :: Parser (Maybe Int) optMeetPopularity = optional@@ -263,7 +271,10 @@ >>= validateIntOption (> 0) "--meet-popularity must be positive" >>= validateIntOption (< 100) "--meet-popularity must be <= 100" )- (long "meet-popularity" <> metavar "PERCENTAGE" <> help "The minimum popularity of an expression in order to be suitable for \\phiMeet{}, in percentage (default: 50)")+ ( long "meet-popularity"+ <> metavar "PERCENTAGE"+ <> help (printf "The minimum popularity of an expression in order to be suitable for \\phiMeet{}, in percentage (default: %d)" defaultMeetPopularity)+ ) ) optMeetLength :: Parser (Maybe Int)@@ -271,7 +282,10 @@ optional ( option (auto >>= validateIntOption (> 0) "--meet-length must be positive")- (long "meet-length" <> metavar "NODES" <> help "The minimum length of an expression that fits into \\phiMeet{}, in AST nodes (default: 8)")+ ( long "meet-length"+ <> metavar "NODES"+ <> help (printf "The minimum length of an expression that fits into \\phiMeet{}, in AST nodes (default: %d)" defaultMeetLength)+ ) ) optDepthSensitive :: Parser Bool@@ -391,6 +405,7 @@ <*> optCompress <*> optMaxDepth <*> optMaxCycles+ <*> optMargin <*> optMeetPopularity <*> optMeetLength <*> optHide@@ -434,6 +449,7 @@ <*> optCompress <*> optMaxDepth <*> optMaxCycles+ <*> optMargin <*> optMeetPopularity <*> optMeetLength <*> optRule@@ -461,6 +477,7 @@ <*> optLineFormat' <*> optOmitListing <*> optOmitComments+ <*> optMargin <*> optTarget <*> many (argument str (metavar "[FILE]" <> help "Paths to input files")) )@@ -529,7 +546,7 @@ input <- readInput _inputFile rules <- getRules _normalize _shuffle _rules program <- parseProgram input _inputFormat- let listing = if null rules then const input else (\prog -> P.printProgram' prog (_sugarType, UNICODE, _flat))+ let listing = if null rules then const input else (\prog -> P.printProgram' prog (_sugarType, UNICODE, _flat, _margin)) xmirCtx = XmirContext _omitListing _omitComments listing printCtx = printProgCtx xmirCtx foc canonize = if _canonize then C.canonize else id@@ -587,6 +604,7 @@ PrintProgCtx _sugarType _flat+ _margin xmirCtx _nonumber _compress@@ -638,6 +656,7 @@ PrintProgCtx _sugarType _flat+ _margin defaultXmirContext _nonumber _compress@@ -664,7 +683,7 @@ inputs' <- traverse (readInput . Just) _inputs progs <- traverse (`parseProgram` _inputFormat) inputs' prog <- merge progs- let listing = const (P.printProgram' prog (_sugarType, UNICODE, _flat))+ let listing = const (P.printProgram' prog (_sugarType, UNICODE, _flat, _margin)) xmirCtx = XmirContext _omitListing _omitComments listing printCtx = printProgCtx xmirCtx prog' <- printProgram printCtx prog@@ -681,6 +700,7 @@ PrintProgCtx _sugarType _flat+ _margin xmirCtx False False@@ -703,16 +723,16 @@ substs <- matchProgramWithRule prog (rule ptn condition) (RuleContext buildTerm) if null substs then logDebug "Provided pattern was not matched, no substitutions are built"- else putStrLn (P.printSubsts' substs (_sugarType, UNICODE, _flat))+ else putStrLn (P.printSubsts' substs (_sugarType, UNICODE, _flat, defaultMargin)) where rule :: Expression -> Maybe Y.Condition -> Y.Rule rule ptn cnd = Y.Rule Nothing Nothing ptn ExGlobal cnd Nothing Nothing justMeetPopularity :: Maybe Int -> Int-justMeetPopularity = fromMaybe 50+justMeetPopularity = fromMaybe defaultMeetPopularity justMeetLength :: Maybe Int -> Int-justMeetLength = fromMaybe 8+justMeetLength = fromMaybe defaultMeetLength -- Prepare saveStepFunc saveStepFunc :: Maybe FilePath -> PrintProgramContext -> SaveStepFunc@@ -786,23 +806,23 @@ printRewrittens :: PrintProgramContext -> [Rewritten] -> IO String printRewrittens ctx@PrintProgCtx{..} rewrittens- | _outputFormat == LATEX && _sequence = rewrittensToLatex rewrittens (LatexContext _sugar _line _nonumber _compress _meetPopularity _meetLength _focus _expression _label _meetPrefix)+ | _outputFormat == LATEX && _sequence = rewrittensToLatex rewrittens (LatexContext _sugar _line _margin _nonumber _compress _meetPopularity _meetLength _focus _expression _label _meetPrefix) | _focus == ExGlobal = mapM (printProgram ctx . fst) rewrittens <&> intercalate "\n" | otherwise = mapM (\(prog, _) -> locatedExpression _focus prog >>= printExpression ctx) rewrittens <&> intercalate "\n" printExpression :: PrintProgramContext -> Expression -> IO String printExpression PrintProgCtx{..} ex = case _outputFormat of- PHI -> pure (P.printExpression' ex (_sugar, UNICODE, _line))+ PHI -> pure (P.printExpression' ex (_sugar, UNICODE, _line, _margin)) XMIR -> throwIO CouldNotPrintExpressionInXMIR- LATEX -> pure (expressionToLaTeX ex (LatexContext _sugar _line _nonumber _compress _meetPopularity _meetLength _focus _expression _label _meetPrefix))+ LATEX -> pure (expressionToLaTeX ex (LatexContext _sugar _line _margin _nonumber _compress _meetPopularity _meetLength _focus _expression _label _meetPrefix)) -- Convert -- Convert program to corresponding String format printProgram :: PrintProgramContext -> Program -> IO String printProgram PrintProgCtx{..} prog = case _outputFormat of- PHI -> pure (P.printProgram' prog (_sugar, UNICODE, _line))+ PHI -> pure (P.printProgram' prog (_sugar, UNICODE, _line, _margin)) XMIR -> programToXMIR prog _xmirCtx <&> printXMIR- LATEX -> pure (programToLaTeX prog (LatexContext _sugar _line _nonumber _compress _meetPopularity _meetLength _focus _expression _label _meetPrefix))+ LATEX -> pure (programToLaTeX prog (LatexContext _sugar _line _margin _nonumber _compress _meetPopularity _meetLength _focus _expression _label _meetPrefix)) -- Get rules for rewriting depending on provided flags getRules :: Bool -> Bool -> [FilePath] -> IO [Y.Rule]
src/CST.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-partial-fields -Wno-name-shadowing #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com@@ -12,7 +10,7 @@ import AST import Data.Maybe (isJust)-import Misc (btsToNum, btsToStr, matchDataObject, pattern BaseObject, pattern DataNumber, pattern DataString)+import Misc data LCB = LCB | BIG_LCB deriving (Eq, Show)@@ -56,9 +54,6 @@ data GLOBAL = Φ | Q deriving (Eq, Show) -data DEF_PACKAGE = Φ̇ | QQ- deriving (Eq, Show)- data TERMINATION = DEAD | T deriving (Eq, Show) @@ -170,33 +165,33 @@ deriving (Eq, Show) programToCST :: Program -> PROGRAM-programToCST prog = toCST prog 0 EOL+programToCST prog = toCST prog (0, EOL) expressionToCST :: Expression -> EXPRESSION-expressionToCST ex = toCST ex 0 EOL+expressionToCST ex = toCST ex (0, EOL) -- This class is used to convert AST to CST -- CST is created with sugar and unicode--- All further transformations much consider that+-- All further transformations must consider that class ToCST a b where- toCST :: a -> Int -> EOL -> b+ toCST :: a -> (Int, EOL) -> b instance ToCST Program PROGRAM where- toCST (Program expr) tabs eol = PR_SWEET LCB (toCST expr tabs eol) RCB+ toCST (Program expr) ctx = PR_SWEET LCB (toCST expr ctx) RCB instance ToCST Expression EXPRESSION where- toCST ExGlobal _ _ = EX_GLOBAL Φ- toCST ExThis _ _ = EX_XI XI- toCST (ExMeta mt) _ _ = EX_META (MT_EXPRESSION (tail mt))- toCST (ExMetaTail expr mt) tabs eol = EX_META_TAIL (toCST expr tabs eol) (MT_TAIL (tail mt))- toCST ExTermination _ _ = EX_TERMINATION DEAD- toCST (ExFormation [BiVoid AtRho]) _ eol = toCST (ExFormation []) 0 eol- toCST (ExFormation []) _ _ = EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY NO_TAB) NO_EOL NO_TAB RSB- toCST (ExPhiMeet prefix idx expr) tabs eol = EX_PHI_MEET prefix idx (toCST expr tabs eol)- toCST (ExPhiAgain prefix idx expr) tabs eol = EX_PHI_AGAIN prefix idx (toCST expr tabs eol)- toCST (ExFormation bds) tabs eol =+ toCST ExGlobal _ = EX_GLOBAL Φ+ toCST ExThis _ = EX_XI XI+ toCST (ExMeta mt) _ = EX_META (MT_EXPRESSION (tail mt))+ toCST (ExMetaTail expr mt) ctx = EX_META_TAIL (toCST expr ctx) (MT_TAIL (tail mt))+ toCST ExTermination _ = EX_TERMINATION DEAD+ toCST (ExPhiMeet prefix idx expr) ctx = EX_PHI_MEET prefix idx (toCST expr ctx)+ toCST (ExPhiAgain prefix idx expr) ctx = EX_PHI_AGAIN prefix idx (toCST expr ctx)+ toCST (ExFormation [BiVoid AtRho]) ctx = toCST (ExFormation []) ctx+ toCST (ExFormation []) _ = EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY NO_TAB) NO_EOL NO_TAB RSB+ toCST (ExFormation bds) (tabs, eol) = let next = tabs + 1- bds' = toCST (withoutLastVoidRho bds) next eol :: BINDING+ bds' = toCST (withoutLastVoidRho bds) (next, eol) :: BINDING in EX_FORMATION LSB EOL@@ -209,25 +204,24 @@ withoutLastVoidRho :: [Binding] -> [Binding] withoutLastVoidRho [] = [] withoutLastVoidRho [BiVoid AtRho] = []- withoutLastVoidRho (bd : [BiVoid AtRho]) = [bd] withoutLastVoidRho (bd : bds') = bd : withoutLastVoidRho bds'- toCST (DataString bts) tabs _ = EX_STRING (btsToStr bts) (TAB tabs) []- toCST (DataNumber bts) tabs _ = EX_NUMBER (btsToNum bts) (TAB tabs) []- toCST (ExDispatch ExThis attr) tabs eol = EX_ATTR (toCST attr tabs eol)- toCST (ExDispatch expr attr) tabs eol = EX_DISPATCH (toCST expr tabs eol) (toCST attr tabs eol)+ toCST (DataString bts) (tabs, _) = EX_STRING (btsToStr bts) (TAB tabs) []+ toCST (DataNumber bts) (tabs, _) = EX_NUMBER (btsToNum bts) (TAB tabs) []+ toCST (ExDispatch ExThis attr) ctx = EX_ATTR (toCST attr ctx)+ toCST (ExDispatch expr attr) ctx = EX_DISPATCH (toCST expr ctx) (toCST attr ctx) -- Since we convert AST to CST in sweet notation, here we're trying to get rid of unnecessary rho bindings -- in primitives (more details here: https://github.com/objectionary/phino/issues/451) -- If we find something similar to:- -- `QQ.number(~0 -> QQ.bytes(...), ^ -> ..., ^ -> ...)`+ -- `Q.number(~0 -> Q.bytes(...), ^ -> ..., ^ -> ...)` -- We remove unnecessary rho bindings and save them to EX_STRING or EX_NUMBER so they can be successfully -- converted to salty notation without losing information. -- In the end we just get CST with data primitive which is printed correctly. -- If given application is not such primitive - we just convert it to one of the applications: -- 1. either with pure expression with arguments, which means there are incremented only alpha bindings -- 2. or with just bindings- toCST app@(ExApplication _ _) tabs eol =+ toCST app@(ExApplication _ _) ctx@(tabs, eol) = let (ex, ts, exs) = complexApplication app- ex' = toCST ex tabs eol :: EXPRESSION+ ex' = toCST ex ctx :: EXPRESSION next = tabs + 1 (ts', rs) = withoutRhosInPrimitives ex ts obj = ExApplication ex (head ts')@@ -236,25 +230,23 @@ else if null exs then- let eol' = inlinedEOL (not (hasEOL ts))- in EX_APPLICATION_TAUS- ex'- eol'- (tabOfEOL eol' next)- (toCST ts next eol' :: BINDING)- eol'- (tabOfEOL eol' tabs)- next+ EX_APPLICATION_TAUS+ ex'+ eol+ (TAB next)+ (toCST ts (next, eol) :: BINDING)+ eol+ (TAB tabs)+ next else- let eol' = inlinedEOL (not (hasEOL exs))- in EX_APPLICATION_EXPRS- ex'- eol'- (tabOfEOL eol' next)- (toCST exs next eol')- eol'- (tabOfEOL eol' tabs)- next+ EX_APPLICATION_EXPRS+ ex'+ eol+ (TAB next)+ (toCST exs (next, eol))+ eol+ (TAB tabs)+ next where primitives :: [String] primitives = ["number", "string"]@@ -303,97 +295,64 @@ complexApplication' expr = (expr, [], []) instance ToCST [Expression] APP_ARG where- toCST (expr : exprs) tabs eol = APP_ARG (toCST expr tabs eol) (toCST exprs tabs eol)- toCST [] _ _ = error "toCST APP_ARG requires non-empty expression list"+ toCST (expr : exprs) ctx = APP_ARG (toCST expr ctx) (toCST exprs ctx)+ toCST [] _ = error "toCST APP_ARG requires non-empty expression list" instance ToCST [Expression] APP_ARGS where- toCST [] _ _ = AAS_EMPTY- toCST (expr : exprs) tabs eol = AAS_EXPR eol (tabOfEOL eol tabs) (toCST expr tabs eol) (toCST exprs tabs eol)+ toCST [] _ = AAS_EMPTY+ toCST (expr : exprs) ctx@(tabs, eol) = AAS_EXPR eol (TAB tabs) (toCST expr ctx) (toCST exprs ctx) instance ToCST [Binding] BINDING where- toCST [] tabs _ = BI_EMPTY (TAB tabs)- toCST (BiMeta mt : bds) tabs eol = BI_META (MT_BINDING (tail mt)) (toCST bds tabs eol) (tabOfEOL eol tabs)- toCST (bd : bds) tabs eol = BI_PAIR (toCST bd tabs eol) (toCST bds tabs eol) (tabOfEOL eol tabs)+ toCST [] (tabs, _) = BI_EMPTY (TAB tabs)+ toCST (BiMeta mt : bds) ctx@(tabs, _) = BI_META (MT_BINDING (tail mt)) (toCST bds ctx) (TAB tabs)+ toCST (bd : bds) ctx@(tabs, _) = BI_PAIR (toCST bd ctx) (toCST bds ctx) (TAB tabs) instance ToCST [Binding] BINDINGS where- toCST [] tabs _ = BDS_EMPTY (TAB tabs)- toCST (BiMeta mt : bds) tabs eol = BDS_META eol (tabOfEOL eol tabs) (MT_BINDING (tail mt)) (toCST bds tabs eol)- toCST (bd : bds) tabs eol = BDS_PAIR eol (tabOfEOL eol tabs) (toCST bd tabs eol) (toCST bds tabs eol)+ toCST [] (tabs, _) = BDS_EMPTY (TAB tabs)+ toCST (BiMeta mt : bds) ctx@(tabs, eol) = BDS_META eol (TAB tabs) (MT_BINDING (tail mt)) (toCST bds ctx)+ toCST (bd : bds) ctx@(tabs, eol) = BDS_PAIR eol (TAB tabs) (toCST bd ctx) (toCST bds ctx) instance ToCST Binding PAIR where- toCST (BiTau attr exp@(ExFormation bds)) tabs eol =+ toCST (BiTau attr exp@(ExFormation bds)) ctx = let voids' = voids bds- attr' = toCST attr tabs eol+ attr' = toCST attr ctx in if null voids'- then PA_TAU attr' ARROW (toCST exp tabs eol)+ then PA_TAU attr' ARROW (toCST exp ctx) else let (_voids, _bds) = if length voids' == length bds && last voids' == AtRho then (init voids', []) else (voids', drop (length voids') bds) in PA_FORMATION attr'- (map (\at -> toCST at tabs eol) _voids)+ (map (`toCST` ctx) _voids) ARROW- (toCST (ExFormation _bds) tabs eol)+ (toCST (ExFormation _bds) ctx) where voids :: [Binding] -> [Attribute] voids [] = [] voids (bd : bds) = case bd of BiVoid attr -> attr : voids bds _ -> []- toCST (BiTau attr exp) tabs eol = PA_TAU (toCST attr tabs eol) ARROW (toCST exp tabs eol)- toCST (BiVoid attr) tabs eol = PA_VOID (toCST attr tabs eol) ARROW EMPTY- toCST (BiDelta bts) tabs eol = PA_DELTA (toCST bts tabs eol)- toCST (BiLambda func) _ _ = PA_LAMBDA func- toCST (BiMetaLambda mt) _ _ = PA_META_LAMBDA (MT_FUNCTION (tail mt))- toCST (BiMeta mt) _ _ = error $ "BiMeta binding " ++ mt ++ " cannot be converted to PAIR"+ toCST (BiTau attr exp) ctx = PA_TAU (toCST attr ctx) ARROW (toCST exp ctx)+ toCST (BiVoid attr) ctx = PA_VOID (toCST attr ctx) ARROW EMPTY+ toCST (BiDelta bts) ctx = PA_DELTA (toCST bts ctx)+ toCST (BiLambda func) _ = PA_LAMBDA func+ toCST (BiMetaLambda mt) _ = PA_META_LAMBDA (MT_FUNCTION (tail mt))+ toCST (BiMeta mt) _ = error $ "BiMeta binding " ++ mt ++ " cannot be converted to PAIR" instance ToCST Binding APP_BINDING where- toCST bd@(BiTau _ _) tabs eol = APP_BINDING (toCST bd tabs eol :: PAIR)- toCST bd _ _ = error $ "Only BiTau binding can be converted to APP_BINDING, got: " ++ show bd+ toCST bd@(BiTau _ _) ctx = APP_BINDING (toCST bd ctx :: PAIR)+ toCST bd _ = error $ "Only BiTau binding can be converted to APP_BINDING, got: " ++ show bd instance ToCST Bytes BYTES where- toCST BtEmpty _ _ = BT_EMPTY- toCST (BtOne byte) _ _ = BT_ONE byte- toCST (BtMany bts) _ _ = BT_MANY bts- toCST (BtMeta mt) _ _ = BT_META (MT_BYTES (tail mt))+ toCST BtEmpty _ = BT_EMPTY+ toCST (BtOne byte) _ = BT_ONE byte+ toCST (BtMany bts) _ = BT_MANY bts+ toCST (BtMeta mt) _ = BT_META (MT_BYTES (tail mt)) instance ToCST Attribute ATTRIBUTE where- toCST (AtLabel label) _ _ = AT_LABEL label- toCST (AtAlpha idx) _ _ = AT_ALPHA ALPHA idx- toCST AtPhi _ _ = AT_PHI PHI- toCST AtRho _ _ = AT_RHO RHO- toCST AtDelta _ _ = AT_DELTA DELTA- toCST AtLambda _ _ = AT_LAMBDA LAMBDA- toCST (AtMeta mt) _ _ = AT_META (MT_ATTRIBUTE (tail mt))--inlinedEOL :: Bool -> EOL-inlinedEOL True = NO_EOL-inlinedEOL False = EOL--tabOfEOL :: EOL -> Int -> TAB-tabOfEOL EOL indent = TAB indent-tabOfEOL NO_EOL _ = TAB'--class HasEOL a where- hasEOL :: a -> Bool--instance HasEOL [Binding] where- hasEOL [] = False- hasEOL (bd : rest) = hasEOL bd || hasEOL rest--instance HasEOL Binding where- hasEOL (BiTau _ expr) = hasEOL expr- hasEOL _ = False--instance HasEOL [Expression] where- hasEOL [] = False- hasEOL (expr : rest) = hasEOL expr || hasEOL rest--instance HasEOL Expression where- hasEOL (ExFormation []) = False- hasEOL (ExFormation _) = True- hasEOL (DataNumber _) = False- hasEOL (DataString _) = False- hasEOL (BaseObject _) = False- hasEOL (ExDispatch expr _) = hasEOL expr- hasEOL (ExApplication expr tau) = hasEOL expr || hasEOL tau- hasEOL _ = False+ toCST (AtLabel label) _ = AT_LABEL label+ toCST (AtAlpha idx) _ = AT_ALPHA ALPHA idx+ toCST AtPhi _ = AT_PHI PHI+ toCST AtRho _ = AT_RHO RHO+ toCST AtDelta _ = AT_DELTA DELTA+ toCST AtLambda _ = AT_LAMBDA LAMBDA+ toCST (AtMeta mt) _ = AT_META (MT_ATTRIBUTE (tail mt))
src/Canonizer.hs view
@@ -1,6 +1,9 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT +-- Canonization is the process of replacing function names attrached to+-- lambda bindings with numbered identifiers started from 'F'+-- like 'F1', 'F2', etc. module Canonizer (canonize) where import AST
src/Encoding.hs view
@@ -11,8 +11,8 @@ deriving (Eq, Show) withEncoding :: (ToASCII a) => Encoding -> a -> a-withEncoding UNICODE prog = prog-withEncoding ASCII prog = toASCII prog+withEncoding UNICODE node = node+withEncoding ASCII node = toASCII node class ToASCII a where toASCII :: a -> a
src/LaTeX.hs view
@@ -12,6 +12,8 @@ , programToLaTeX , expressionToLaTeX , defaultLatexContext+ , defaultMeetLength+ , defaultMeetPopularity , LatexContext (..) , meetInPrograms , meetInProgram@@ -24,6 +26,7 @@ import Encoding (Encoding (ASCII), ToASCII, withEncoding) import Lining (LineFormat (MULTILINE), ToSingleLine, withLineFormat) import Locator (locatedExpression)+import Margin (WithMargin, defaultMargin, withMargin) import Matcher import Misc import Render (Render (render))@@ -36,6 +39,7 @@ data LatexContext = LatexContext { _sugar :: SugarType , _line :: LineFormat+ , _margin :: Int , _nonumber :: Bool , _compress :: Bool , _meetPopularity :: Int@@ -47,8 +51,14 @@ } defaultLatexContext :: LatexContext-defaultLatexContext = LatexContext SWEET MULTILINE False False 50 8 ExGlobal Nothing Nothing Nothing+defaultLatexContext = LatexContext SWEET MULTILINE defaultMargin False False defaultMeetPopularity defaultMeetLength ExGlobal Nothing Nothing Nothing +defaultMeetPopularity :: Int+defaultMeetPopularity = 50++defaultMeetLength :: Int+defaultMeetLength = 8+ meetInProgram :: Program -> Int -> Program -> [Expression] meetInProgram (Program expr) len = meetInExpression expr where@@ -112,8 +122,8 @@ popularity :: Double popularity = toDouble _meetPopularity / 100.0 -renderToLatex :: (ToSalty a, ToASCII a, ToSingleLine a, ToLaTeX a, Render a) => a -> LatexContext -> String-renderToLatex renderable LatexContext{..} = render (toLaTeX $ withLineFormat _line $ withEncoding ASCII $ withSugarType _sugar renderable)+renderToLatex :: (ToSalty a, ToASCII a, ToSingleLine a, ToLaTeX a, WithMargin a, Render a) => a -> LatexContext -> String+renderToLatex renderable LatexContext{..} = render (toLaTeX $ withLineFormat _line $ withMargin _margin $ withEncoding ASCII $ withSugarType _sugar renderable) phiquation :: LatexContext -> String phiquation LatexContext{_nonumber = True} = "phiquation*"@@ -121,12 +131,11 @@ preamble :: LatexContext -> String preamble ctx@LatexContext{..} =- let equation = phiquation ctx- in concat- [ printf "\\begin{%s}\n" equation- , maybe "" (printf "\\label{%s}\n") _label- , maybe "" (printf "\\phiExpression{%s} ") _expression- ]+ concat+ [ printf "\\begin{%s}\n" (phiquation ctx)+ , maybe "" (printf "\\label{%s}\n") _label+ , maybe "" (printf "\\phiExpression{%s} ") _expression+ ] body :: [(a, Maybe String)] -> (a -> String) -> String body printed toLatex =@@ -143,8 +152,8 @@ ending :: LatexContext -> String ending ctx = printf "{.}\n\\end{%s}" (phiquation ctx) -metRewrittens :: [Rewritten] -> LatexContext -> [Rewritten]-metRewrittens rewrittens ctx@LatexContext{..} =+compressedRewrittens :: [Rewritten] -> LatexContext -> [Rewritten]+compressedRewrittens rewrittens ctx@LatexContext{..} = let (progs, rules) = unzip rewrittens in if _compress then zip (meetInPrograms progs ctx) rules else rewrittens @@ -153,12 +162,12 @@ pure ( concat [ preamble ctx- , body (metRewrittens rewrittens ctx) (\prog -> renderToLatex (programToCST prog) ctx)+ , body (compressedRewrittens rewrittens ctx) (\prog -> renderToLatex (programToCST prog) ctx) , ending ctx ] ) rewrittensToLatex rewrittens ctx@LatexContext{..} = do- let (progs, rules) = unzip (metRewrittens rewrittens ctx)+ let (progs, rules) = unzip (compressedRewrittens rewrittens ctx) exprs <- mapM (locatedExpression _focus) progs pure ( concat
src/Lining.hs view
@@ -9,8 +9,8 @@ import CST withLineFormat :: (ToSingleLine a) => LineFormat -> a -> a-withLineFormat MULTILINE prog = prog-withLineFormat SINGLELINE prog = toSingleLine prog+withLineFormat MULTILINE node = node+withLineFormat SINGLELINE node = toSingleLine node data LineFormat = SINGLELINE | MULTILINE deriving (Show, Eq)
src/Logger.hs view
@@ -5,11 +5,9 @@ module Logger ( logDebug- , logInfo- , logWarning , logError , setLogConfig- , LogLevel (DEBUG, INFO, WARNING, ERROR, NONE)+ , LogLevel (DEBUG, ERROR, NONE) ) where @@ -19,14 +17,14 @@ import GHC.IO (unsafePerformIO) import System.IO -data LogLevel = DEBUG | INFO | WARNING | ERROR | NONE+data LogLevel = DEBUG | ERROR | NONE deriving (Show, Ord, Eq, Bounded, Enum, Read) data Logger = Logger {level :: LogLevel, lns :: Int} logger :: IORef Logger {-# NOINLINE logger #-}-logger = unsafePerformIO (newIORef (Logger INFO 25))+logger = unsafePerformIO (newIORef (Logger ERROR 25)) setLogConfig :: LogLevel -> Int -> IO () setLogConfig lvl cnt = writeIORef logger (Logger lvl cnt)@@ -45,8 +43,6 @@ in hPutStrLn stderr ("[" ++ show lvl ++ "]: " ++ DL.intercalate "\n" msg) ) -logDebug, logInfo, logWarning, logError :: String -> IO ()+logDebug, logError :: String -> IO () logDebug = logMessage DEBUG-logInfo = logMessage INFO-logWarning = logMessage WARNING logError = logMessage ERROR
+ src/Margin.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module Margin (defaultMargin, withMargin, WithMargin) where++import CST+import Lining (ToSingleLine (..))+import Render (Render (..))++defaultMargin :: Int+defaultMargin = 80++withMargin :: (WithMargin a) => Int -> a -> a+withMargin margin = withMargin' (0, margin)++class WithMargin a where+ withMargin' :: (Int, Int) -> a -> a++instance WithMargin PROGRAM where+ withMargin' (_, margin) PR_SWEET{..} = PR_SWEET lcb (withMargin' (2, margin) expr) rcb+ withMargin' (_, margin) PR_SALTY{..} =+ let before = lengthOf global + lengthOf arrow + 2 -- 'Q -> '+ in PR_SALTY global arrow (withMargin' (before, margin) expr)++instance WithMargin EXPRESSION where+ withMargin' _ ex@EX_FORMATION{binding = BI_EMPTY{}} = ex+ withMargin' (extra, margin) ex@EX_FORMATION{tab = tab@(TAB indent), ..} =+ let single = toSingleLine ex+ ex' = EX_FORMATION lsb EOL tab (withMargin' (indent, margin) binding) EOL tab' rsb+ in if lengthOf single + extra <= margin then single else ex'+ withMargin' _ num@EX_NUMBER{} = num+ withMargin' _ str@EX_STRING{} = str+ withMargin' cfg EX_DISPATCH{..} = EX_DISPATCH (withMargin' cfg expr) attr+ withMargin' cfg EX_META_TAIL{..} = EX_META_TAIL (withMargin' cfg expr) meta+ withMargin' cfg EX_PHI_AGAIN{..} = EX_PHI_AGAIN prefix idx (withMargin' cfg expr)+ withMargin' cfg EX_PHI_MEET{..} = EX_PHI_MEET prefix idx (withMargin' cfg expr)+ withMargin' cfg@(extra, margin) ex@EX_APPLICATION{tab = tab@(TAB indt), ..} =+ let single = toSingleLine ex+ main = withMargin' cfg expr+ singleMain = toSingleLine main+ extra' = length (last (lines (render main))) + 4 -- 2 spaces + 2 braces around argument+ arg = withMargin' (indt, margin) tau+ singleArg = toSingleLine arg+ in if+ | lengthOf single + extra <= margin -> single+ | lengthOf singleMain + extra <= margin -> EX_APPLICATION singleMain EOL tab arg EOL tab' indent+ | lengthOf singleArg + extra' <= margin -> EX_APPLICATION main NO_EOL TAB' singleArg NO_EOL TAB' indent+ | otherwise -> EX_APPLICATION main EOL tab arg EOL tab' indent+ withMargin' cfg@(extra, margin) ex@EX_APPLICATION_EXPRS{tab = tab@(TAB indt), ..} =+ let single = toSingleLine ex+ main = withMargin' cfg expr+ singleMain = toSingleLine main+ extra' = length (last (lines (render main))) + 4 -- 2 spaces + 2 braces around arguments+ exprs = withMargin' (indt, margin) args+ singleExprs = toSingleLine exprs+ in if+ | lengthOf single + extra <= margin -> single+ | lengthOf singleMain + extra <= margin -> EX_APPLICATION_EXPRS singleMain EOL tab exprs EOL tab' indent+ | lengthOf singleExprs + extra' <= margin -> EX_APPLICATION_EXPRS main NO_EOL TAB' singleExprs NO_EOL TAB' indent+ | otherwise -> EX_APPLICATION_EXPRS main EOL tab exprs EOL tab' indent+ withMargin' cfg@(extra, margin) ex@EX_APPLICATION_TAUS{tab = tab@(TAB indt), ..} =+ let single = toSingleLine ex+ main = withMargin' cfg expr+ singleMain = toSingleLine main+ extra' = length (last (lines (render main))) + 4 -- 2 spaces + 2 braces around arguments+ taus' = withMargin' (indt, margin) taus+ singleTaus = toSingleLine taus'+ in if+ | lengthOf single + extra <= margin -> single+ | lengthOf singleMain + extra <= margin -> EX_APPLICATION_TAUS singleMain EOL tab taus' EOL tab' indent+ | lengthOf singleTaus + extra' <= margin -> EX_APPLICATION_TAUS main NO_EOL TAB' singleTaus NO_EOL TAB' indent+ | otherwise -> EX_APPLICATION_TAUS main EOL tab taus' EOL tab' indent+ withMargin' _ ex = ex++instance WithMargin APP_BINDING where+ withMargin' cfg APP_BINDING{..} = APP_BINDING (withMargin' cfg pair)++instance WithMargin APP_ARG where+ withMargin' cfg@(extra, margin) arg@APP_ARG{..} =+ let single = toSingleLine arg+ in if lengthOf single + extra <= margin then single else APP_ARG (withMargin' cfg expr) (withMargin' cfg args)++instance WithMargin APP_ARGS where+ withMargin' cfg AAS_EXPR{..} = AAS_EXPR EOL tab (withMargin' cfg expr) (withMargin' cfg args)+ withMargin' _ args = args++instance WithMargin BINDING where+ withMargin' cfg BI_PAIR{..} = BI_PAIR (withMargin' cfg pair) (withMargin' cfg bindings) tab+ withMargin' cfg BI_META{..} = BI_META meta (withMargin' cfg bindings) tab+ withMargin' _ bd = bd++instance WithMargin BINDINGS where+ withMargin' cfg BDS_PAIR{..} = BDS_PAIR EOL tab (withMargin' cfg pair) (withMargin' cfg bindings)+ withMargin' cfg BDS_META{..} = BDS_META EOL tab meta (withMargin' cfg bindings)+ withMargin' _ bds = bds++instance WithMargin PAIR where+ withMargin' (extra, margin) pa@PA_TAU{..} =+ let single = toSingleLine pa+ extra' = extra + lengthOf attr + lengthOf arrow + 2 -- indent + attr + arrow + 2 spaces+ pa' = PA_TAU attr arrow (withMargin' (extra', margin) expr)+ in if lengthOf single + extra <= margin then single else pa'+ withMargin' (extra, margin) pa@PA_FORMATION{..} =+ let single = toSingleLine pa+ extra' = extra + lengthOf attr + lengthOf voids + lengthOf arrow + 4 -- indent + 2 braces + 2 spaces + voids+ pa' = PA_FORMATION attr voids arrow (withMargin' (extra', margin) expr)+ in if lengthOf single + extra <= margin then single else pa'+ withMargin' _ pa = pa++lengthOf :: Render a => a -> Int+lengthOf renderable = length (render renderable)
src/Printer.hs view
@@ -26,38 +26,39 @@ import qualified Data.Map.Strict as Map import Encoding import Lining+import Margin (defaultMargin, withMargin) import Matcher import Render import Sugar import Yaml (ExtraArgument (ArgAttribute, ArgBinding, ArgBytes, ArgExpression)) import Prelude hiding (print) -type PrintConfig = (SugarType, Encoding, LineFormat)+type PrintConfig = (SugarType, Encoding, LineFormat, Int) defaultPrintConfig :: PrintConfig-defaultPrintConfig = (SWEET, UNICODE, MULTILINE)+defaultPrintConfig = (SWEET, UNICODE, MULTILINE, defaultMargin) -logPrintConfig :: (SugarType, Encoding, LineFormat)-logPrintConfig = (SWEET, UNICODE, SINGLELINE)+logPrintConfig :: (SugarType, Encoding, LineFormat, Int)+logPrintConfig = (SWEET, UNICODE, SINGLELINE, defaultMargin) printProgram' :: Program -> PrintConfig -> String-printProgram' prog (sugar, encoding, line) = render (withLineFormat line $ withEncoding encoding $ withSugarType sugar $ programToCST prog)+printProgram' prog (sugar, encoding, line, margin) = render (withLineFormat line $ withMargin margin $ withEncoding encoding $ withSugarType sugar $ programToCST prog) printProgram :: Program -> String printProgram prog = printProgram' prog defaultPrintConfig printExpression' :: Expression -> PrintConfig -> String-printExpression' ex (sugar, encoding, line) = render (withLineFormat line $ withEncoding encoding $ withSugarType sugar $ expressionToCST ex)+printExpression' ex (sugar, encoding, line, margin) = render (withLineFormat line $ withMargin margin $ withEncoding encoding $ withSugarType sugar $ expressionToCST ex) printExpression :: Expression -> String printExpression ex = printExpression' ex defaultPrintConfig printAttribute' :: Attribute -> Encoding -> String-printAttribute' att encoding = render (withEncoding encoding (toCST att 0 NO_EOL :: ATTRIBUTE))+printAttribute' att encoding = render (withEncoding encoding (toCST att (0, NO_EOL) :: ATTRIBUTE)) printAttribute :: Attribute -> String printAttribute att =- let (_, encoding, _) = defaultPrintConfig+ let (_, encoding, _, _) = defaultPrintConfig in printAttribute' att encoding printBinding' :: Binding -> PrintConfig -> String@@ -67,10 +68,10 @@ printBinding bd = printBinding' bd defaultPrintConfig printBytes :: Bytes -> String-printBytes bts = render (toCST bts 0 NO_EOL :: BYTES)+printBytes bts = render (toCST bts (0, NO_EOL) :: BYTES) printExtraArg' :: ExtraArgument -> PrintConfig -> String-printExtraArg' (ArgAttribute att) (_, encoding, _) = printAttribute' att encoding+printExtraArg' (ArgAttribute att) (_, encoding, _, _) = printAttribute' att encoding printExtraArg' (ArgBinding bd) config = printBinding' bd config printExtraArg' (ArgExpression ex) config = printExpression' ex config printExtraArg' (ArgBytes bts) _ = printBytes bts@@ -80,10 +81,10 @@ printTail :: Tail -> PrintConfig -> String printTail (TaApplication bd) config = "(" <> printBinding' bd config <> ")"-printTail (TaDispatch att) (_, encoding, _) = "." <> printAttribute' att encoding+printTail (TaDispatch att) (_, encoding, _, _) = "." <> printAttribute' att encoding printMetaValue :: MetaValue -> PrintConfig -> String-printMetaValue (MvAttribute att) (_, encoding, _) = printAttribute' att encoding+printMetaValue (MvAttribute att) (_, encoding, _, _) = printAttribute' att encoding printMetaValue (MvExpression ex _) config = printExpression' ex config printMetaValue (MvBytes bts) _ = printBytes bts printMetaValue (MvBindings bds) config = printExpression' (ExFormation bds) config
src/Render.hs view
@@ -81,10 +81,6 @@ render Φ = "Φ" render Q = "Q" -instance Render DEF_PACKAGE where- render Φ̇ = "Φ̇"- render QQ = "QQ"- instance Render TERMINATION where render DEAD = "⊥" render T = "T"@@ -119,7 +115,7 @@ render ALPHA' = "~" instance Render TAB where- render TAB{..} = intercalate "" (replicate indent " ")+ render TAB{..} = concat (replicate indent " ") render TAB' = " " render NO_TAB = "" @@ -130,7 +126,7 @@ instance Render PAIR where render PA_TAU{..} = render attr <> render SPACE <> render arrow <> render SPACE <> render expr render PA_FORMATION{voids = [], attr, arrow, expr} = render (PA_TAU attr arrow expr)- render PA_FORMATION{..} = render attr <> "(" <> intercalate ", " (map render voids) <> ")" <> render SPACE <> render arrow <> render SPACE <> render expr+ render PA_FORMATION{..} = render attr <> "(" <> render voids <> ")" <> render SPACE <> render arrow <> render SPACE <> render expr render PA_LAMBDA{..} = render LAMBDA <> render SPACE <> render DASHED_ARROW <> render SPACE <> render func render PA_LAMBDA'{..} = "L> " <> func render PA_VOID{..} = render attr <> render SPACE <> render arrow <> render SPACE <> render void@@ -177,6 +173,9 @@ render EX_META_TAIL{..} = render expr <> " * " <> render meta render EX_PHI_MEET{..} = "\\phiMeet{" <> maybe "" (++ ":") prefix <> render idx <> "}{ " <> render expr <> " }" render EX_PHI_AGAIN{..} = "\\phiAgain{" <> maybe "" (++ ":") prefix <> render idx <> "}"++instance Render [ATTRIBUTE] where+ render attrs = intercalate ", " (map render attrs) instance Render ATTRIBUTE where render AT_LABEL{..} = label
src/Sugar.hs view
@@ -14,8 +14,8 @@ import Misc (numToBts, strToBts, toDouble, pattern BaseObject) withSugarType :: (ToSalty a) => SugarType -> a -> a-withSugarType SWEET prog = prog-withSugarType SALTY prog = toSalty prog+withSugarType SWEET node = node+withSugarType SALTY node = toSalty node voidRho :: PAIR voidRho = PA_VOID (AT_RHO RHO) ARROW EMPTY@@ -39,18 +39,18 @@ -- By default CST is generated with all possible syntax sugar -- The main purpose of this class is to get rid of syntax sugar--- |----------------------------|-------------------------------------------------------|--- | sugar | verbose version |--- |----------------------------|-------------------------------------------------------|--- | {e} | Q -> e |--- | a1 -> a2 | a1 ↦ $.a2 |--- | a -> 42 | QQ.number(QQ.bytes([[ D> 40-45-00-00-00-00-00-00 ]])) |--- | a -> "Hey" | QQ.number(QQ.bytes([[ D> 48-65-79 ]])) |--- | [[ B ]] | [[ B, ^ -> ? ]], if rho is absent in 'B' |--- | a1(a2, a3, ...) -> [[ B ]] | a1 -> [[ a2 -> ?, a3 -> ?, ..., B ]] |--- | e(e0, e1, ...) | e(~0 -> e0, ~1 -> e1, ...) |--- | e(a1 -> e1, a2 -> e2, ...) | e(a1 -> e1)(a2 -> e2)... |--- |----------------------------|-------------------------------------------------------|+-- |----------------------------|-----------------------------------------------------|+-- | sugar | verbose version |+-- |----------------------------|-----------------------------------------------------|+-- | {e} | Q -> e |+-- | a1 -> a2 | a1 ↦ $.a2 |+-- | a -> 42 | Q.number(Q.bytes([[ D> 40-45-00-00-00-00-00-00 ]])) |+-- | a -> "Hey" | Q.number(Q.bytes([[ D> 48-65-79 ]])) |+-- | [[ B ]] | [[ B, ^ -> ? ]], if rho is absent in 'B' |+-- | a1(a2, a3, ...) -> [[ B ]] | a1 -> [[ a2 -> ?, a3 -> ?, ..., B ]] |+-- | e(e0, e1, ...) | e(~0 -> e0, ~1 -> e1, ...) |+-- | e(a1 -> e1, a2 -> e2, ...) | e(a1 -> e1)(a2 -> e2)... |+-- |----------------------------|-----------------------------------------------------| class ToSalty a where toSalty :: a -> a @@ -93,16 +93,16 @@ argsToBindings AAS_EXPR{..} idx tb = BDS_PAIR eol tb (PA_TAU (AT_ALPHA ALPHA idx) ARROW expr) (argsToBindings args (idx + 1) tb) toSalty EX_NUMBER{num, tab = tab@TAB{..}, rhos} = saltifyPrimitive- (toCST (BaseObject "number") (indent + 1) EOL)- (toCST (BaseObject "bytes") (indent + 2) EOL)- (toCST (ExFormation [BiDelta (numToBts (either toDouble id num))]) (indent + 2) EOL)+ (toCST (BaseObject "number") (indent + 1, EOL))+ (toCST (BaseObject "bytes") (indent + 2, EOL))+ (toCST (ExFormation [BiDelta (numToBts (either toDouble id num))]) (indent + 2, EOL)) tab rhos toSalty EX_STRING{str, tab = tab@TAB{..}, rhos} = saltifyPrimitive- (toCST (BaseObject "string") (indent + 1) EOL)- (toCST (BaseObject "bytes") (indent + 2) EOL)- (toCST (ExFormation [BiDelta (strToBts str)]) (indent + 2) EOL)+ (toCST (BaseObject "string") (indent + 1, EOL))+ (toCST (BaseObject "bytes") (indent + 2, EOL))+ (toCST (ExFormation [BiDelta (strToBts str)]) (indent + 2, EOL)) tab rhos toSalty EX_PHI_MEET{..} = EX_PHI_MEET prefix idx (toSalty expr)@@ -131,7 +131,7 @@ (indent + 2) ) )- (toCST rhos (indent + 1) EOL)+ (toCST rhos (indent + 1, EOL)) next ) EOL
src/XMIR.hs view
@@ -20,7 +20,7 @@ import AST import Control.Exception (Exception (displayException), throwIO)-import qualified Data.Bifunctor+import Data.Bifunctor (bimap) import Data.Foldable (foldlM) import Data.List (intercalate) import qualified Data.Map as M@@ -75,10 +75,10 @@ toName str = Name (T.pack str) Nothing Nothing element :: String -> [(String, String)] -> [Node] -> Element-element name attrs children = do+element name attrs children = let name' = toName name- attrs' = M.fromList (map (Data.Bifunctor.bimap toName T.pack) attrs)- Element name' attrs' children+ attrs' = M.fromList (map (bimap toName T.pack) attrs)+ in Element name' attrs' children object :: [(String, String)] -> [Node] -> Node object attrs children = NodeElement (element "o" attrs children)@@ -245,13 +245,13 @@ ] ) time :: UTCTime -> String- time now = do+ time now = let base = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" now posix = utcTimeToPOSIXSeconds now fractional :: Double fractional = realToFrac posix - fromInteger (floor posix) nanos = floor (fractional * 1_000_000_000) :: Int- base ++ "." ++ printf "%09d" nanos ++ "Z"+ in base ++ "." ++ printf "%09d" nanos ++ "Z" programToXMIR prog _ = throwIO (UnsupportedProgram prog) -- Add indentation (2 spaces per level).
test/CLISpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-} @@ -11,13 +10,14 @@ import Control.Exception import Control.Monad (forM_, unless, when) import Data.List (intercalate, isInfixOf)+import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Version (showVersion) import GHC.IO.Handle import Paths_phino (version)-import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, removeDirectoryRecursive, removeFile)+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, listDirectory, removeDirectoryRecursive, removeFile) import System.Exit (ExitCode (ExitFailure))+import System.FilePath ((</>)) import System.IO-import System.Info (os) import Test.Hspec import Text.Printf (printf) @@ -100,9 +100,6 @@ rule :: String -> String rule file = "--rule=" <> resource file -isWindows :: Bool-isWindows = os == "mingw32"- spec :: Spec spec = do it "prints version" $@@ -114,7 +111,7 @@ ["Phino - CLI Manipulator of 𝜑-Calculus Expressions", "Usage:"] it "prints debug info with --log-level=DEBUG" $- withStdin "Q -> [[]]" $+ withStdin "{[[]]}" $ testCLISucceeded ["rewrite", "--log-level=DEBUG"] ["[DEBUG]:"] describe "rewriting" $ do@@ -138,7 +135,7 @@ ["--max-depth must be positive"] it "with --normalize and --must=1" $- withStdin "Q -> [[ x -> [[ y -> 5 ]].y ]].x" $+ withStdin "{[[ x -> [[ y -> 5 ]].y ]].x}" $ testCLIFailed ["rewrite", "--max-cycles=2", "--max-depth=1", "--normalize", "--must=1"] ["it's expected rewriting cycles to be in range [1], but rewriting has already reached 2"]@@ -179,101 +176,107 @@ ] it "with --output != latex and --nonumber" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--nonumber", "--output=xmir"] ["The --nonumber option can stay together with --output=latex only"] it "with --omit-listing and --output != xmir" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--omit-listing", "--output=phi"] ["--omit-listing"] it "with --omit-comments and --output != xmir" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--omit-comments", "--output=phi"] ["--omit-comments"] it "with --expression and --output != latex" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--expression=foo", "--output=phi"] ["--expression option can stay together with --output=latex only"] it "with --label and --output != latex" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--label=foo", "--output=phi"] ["--label option can stay together with --output=latex only"] it "with --compress and --output != latex" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--compress", "--output=phi"] ["--compress option can stay together with --output=latex only"] it "with --meet-prefix and --output != latex" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--meet-prefix=foo", "--output=phi"] ["--meet-prefix option can stay together with --output=latex only"] it "with wrong --hide option" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--hide=Q.x(Q.y)"] ["[ERROR]: Invalid set of arguments: Only dispatch expression", "but given: Φ.x( Φ.y )"] it "with many --show options" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--show=Q.x.y", "--show=hello"] ["The option --show can be used only once"] it "with wrong --show option" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--show=Q.x(Q.y)"] ["[ERROR]:", "Only dispatch expression started with Φ (or Q) can be used in --show"] it "with --meet-popularity < 0" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--meet-popularity=-1"] ["[ERROR]:", "--meet-popularity must be positive"] it "with --meet-popularity > 100" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--meet-popularity=102"] ["[ERROR]:", "--meet-popularity must be <= 100"] it "with --meet-popularity and output != latex" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--meet-popularity=51", "--output=phi"] ["[ERROR]:", "--meet-popularity option can stay together with --output=latex only"] it "with --meet-length and output != latex" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--meet-length=4", "--output=phi"] ["[ERROR]:", "--meet-length option can stay together with --output=latex only"] it "with non-dispatch --focus" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--focus=Q.x(Q.y)"] ["[ERROR]"] it "with --focus!=Q and --output=XMIR" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["rewrite", "--focus=Q.x", "--output=xmir"] ["[ERROR]"] + it "with --margin < 0" $+ withStdin "" $+ testCLIFailed+ ["rewrite", "--margin=-1"]+ ["[ERROR]"]+ it "prints help" $ testCLISucceeded ["rewrite", "--help"]@@ -297,11 +300,11 @@ it "desugares without any rules flag from file" $ testCLISucceeded ["rewrite", resource "desugar.phi"]- ["Φ ↦ ⟦\n foo ↦ ξ.x,\n ρ ↦ ∅\n⟧"]+ ["Φ ↦ ⟦ foo ↦ ξ.x, ρ ↦ ∅ ⟧"] it "desugares with without any rules flag from stdin" $ withStdin "{[[foo ↦ x]]}" $- testCLISucceeded ["rewrite"] ["Φ ↦ ⟦\n foo ↦ ξ.x,\n ρ ↦ ∅\n⟧"]+ testCLISucceeded ["rewrite"] ["Φ ↦ ⟦ foo ↦ ξ.x, ρ ↦ ∅ ⟧"] it "rewrites with single rule" $ withStdin "{T(x -> Q.y)}" $@@ -309,7 +312,7 @@ it "normalizes with --normalize flag" $ testCLISucceeded- ["rewrite", "--normalize", resource "normalize.phi"]+ ["rewrite", "--normalize", resource "normalize.phi", "--margin=25"] [ unlines [ "Φ ↦ ⟦" , " x ↦ ⟦"@@ -326,7 +329,7 @@ it "normalizes from stdin" $ withStdin "Φ ↦ ⟦ a ↦ ⟦ b ↦ ∅ ⟧ (b ↦ [[ ]]) ⟧" $ testCLISucceeded- ["rewrite", "--normalize"]+ ["rewrite", "--normalize", "--margin=20"] [ unlines [ "Φ ↦ ⟦" , " a ↦ ⟦"@@ -342,7 +345,7 @@ withStdin "Q -> [[ x -> 5]]" $ testCLISucceeded ["rewrite", "--sweet"]- ["{⟦\n x ↦ 5\n⟧}"]+ ["{⟦ x ↦ 5 ⟧}"] it "rewrites as XMIR" $ withStdin "Q -> [[ x -> Q.y ]]" $@@ -406,14 +409,7 @@ withStdin "<object><o name=\"app\"><o name=\"x\" base=\"Φ.number\"/></o></object>" $ testCLISucceeded ["rewrite", "--input=xmir", "--sweet"]- [ unlines- [ "{⟦"- , " app ↦ ⟦"- , " x ↦ Φ.number"- , " ⟧"- , "⟧}"- ]- ]+ ["{⟦ app ↦ ⟦ x ↦ Φ.number ⟧ ⟧}"] it "rewrites as XMIR with omit-listing flag" $ withStdin "Q -> [[ x -> Q.y ]]" $@@ -662,18 +658,13 @@ hClose h testCLISucceeded ["rewrite", rule "simple.yaml", "--in-place", "--sweet", path] [] content <- readFile path- content `shouldBe` "{⟦\n x ↦ \"bar\"\n⟧}"+ content `shouldBe` "{⟦ x ↦ \"bar\" ⟧}" it "rewrites with cycles" $ withStdin "Q -> [[ x -> \"x\" ]]" $ testCLISucceeded ["rewrite", "--sweet", rule "infinite.yaml", "--max-depth=1", "--max-cycles=2"]- [ unlines- [ "{⟦"- , " x ↦ \"x_hi_hi\""- , "⟧}"- ]- ]+ ["{⟦ x ↦ \"x_hi_hi\" ⟧}"] it "hides default package" $ withStdin "{[[ org -> [[ eolang -> [[ number -> [[]] ]]]], x -> 42 ]]}" $@@ -716,14 +707,11 @@ it "reduces log message" $ withStdin "{[[ x -> [[ y -> ? ]](y -> 5) ]]}" $ testCLISucceeded- ["rewrite", "--log-level=debug", "--log-lines=4", "--normalize"]+ ["rewrite", "--log-level=debug", "--log-lines=1", "--normalize"] [ intercalate "\n" [ "[DEBUG]: Applied 'COPY' (44 nodes -> 39 nodes)"- , "⟦"- , " x ↦ ⟦"- , " y ↦ 5"- , "---| log is limited by --log-lines=4 option |---"+ , "---| log is limited by --log-lines=1 option |---" ] ] @@ -779,37 +767,37 @@ describe "fails" $ do it "with --output != latex and --nonumber" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["dataize", "--nonumber", "--output=xmir"] ["The --nonumber option can stay together with --output=latex only"] it "with --omit-listing and --output != xmir" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["dataize", "--omit-listing", "--output=phi"] ["--omit-listing"] it "with --omit-comments and --output != xmir" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["dataize", "--omit-comments", "--output=phi"] ["--omit-comments"] it "with --expression and --output != latex" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["dataize", "--expression=foo", "--output=phi"] ["--expression option can stay together with --output=latex only"] it "with --label and --output != latex" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["dataize", "--label=foo", "--output=phi"] ["--label option can stay together with --output=latex only"] it "with wrong --hide option" $- withStdin "{[[]]}" $+ withStdin "" $ testCLIFailed ["dataize", "--hide=Q.x(Q.y)"] ["[ERROR]: Invalid set of arguments: Only dispatch expression", "but given: Φ.x( Φ.y )"]@@ -836,19 +824,22 @@ ["Either --rule or --normalize must be specified"] it "writes to target file" $- if isWindows- then pendingWith "Skipped on Windows due to file locking issues"- else- bracket- (openTempFile "." "explainXXXXXX.tex")- (\(path, _) -> removeFile path)- ( \(path, h) -> do- hClose h- testCLISucceeded ["explain", "--normalize", printf "--target=%s" path] []- content <- readFile path- content `shouldContain` "\\documentclass{article}"- content `shouldContain` "\\begin{document}"- )+ bracket+ ( do+ tmp <- getTemporaryDirectory+ stamp <- getPOSIXTime+ let dir = tmp </> ("phino-test-" ++ show (floor stamp :: Integer))+ createDirectoryIfMissing True dir+ pure (dir </> "explain.tex", dir)+ )+ (\(_, dir) -> removeDirectoryRecursive dir)+ ( \(path, _) -> do+ testCLISucceeded ["explain", "--normalize", printf "--target=%s" path] []+ content <- readFile path+ _ <- evaluate (length content)+ content `shouldContain` "\\documentclass{article}"+ content `shouldContain` "\\begin{document}"+ ) describe "merge" $ do it "merges single program" $@@ -858,7 +849,7 @@ it "merges EO programs" $ testCLISucceeded- ["merge", "--sweet", resource "number.phi", resource "bytes.phi", resource "string.phi"]+ ["merge", "--sweet", resource "number.phi", resource "bytes.phi", resource "string.phi", "--margin=25"] [ unlines [ "{⟦" , " org ↦ ⟦"@@ -918,7 +909,7 @@ it "builds with condition from file" $ testCLISucceeded ["match", "--pattern=[[ !B ]]", "--when=eq(length(!B),2)", "test-resources/cli/foo.phi"]- ["B >> ⟦\n foo ↦ Φ.org.eolang.x,\n ρ ↦ ∅\n⟧"]+ ["B >> ⟦ foo ↦ Φ.org.eolang.x, ρ ↦ ∅ ⟧"] it "fails on parsing --when condition" $ withStdin "{[[]]}" $
test/CSTSpec.hs view
@@ -14,6 +14,7 @@ import Encoding (Encoding (ASCII), withEncoding) import GHC.Generics (Generic) import Lining (LineFormat (SINGLELINE), withLineFormat)+import Margin (defaultMargin, withMargin) import Misc import Parser (parseProgramThrows) import Render (Render (render))@@ -74,7 +75,7 @@ , ("number(bytes(again(data)))", app number (bt (app bts (bt (again form))))) , ("again(number)(again(bytes)(again(data)))", app (again number) (bt (app (again bts) (bt (again form))))) ]- (\(desc, ex) -> it desc (toCST ex 0 EOL `shouldSatisfy` isCSTNumber))+ (\(desc, ex) -> it desc (toCST ex (0, EOL) `shouldSatisfy` isCSTNumber)) describe "CST printing packs" $ do let resources = "test-resources/cst/printing-packs"@@ -84,7 +85,7 @@ ( \pth -> it (makeRelative resources pth) $ do pack <- cstPack pth prog <- parseProgramThrows (program pack)- render (programToCST prog) `shouldBe` result pack+ render (withMargin defaultMargin (programToCST prog)) `shouldBe` result pack ) describe "converts to salty CST" $ do@@ -109,7 +110,7 @@ pack <- cstPack pth prog <- parseProgramThrows (program pack) let cst = programToCST prog- ascii = withEncoding ASCII cst+ ascii = withMargin defaultMargin (withEncoding ASCII cst) render ascii `shouldBe` result pack )
test/FilterSpec.hs view
@@ -11,7 +11,6 @@ -} module FilterSpec where -import AST import Control.Monad (forM_, when) import Data.Aeson import Data.Yaml qualified as Yaml@@ -19,6 +18,7 @@ import Filter qualified as F import GHC.Generics (Generic) import Lining (LineFormat (MULTILINE))+import Margin (defaultMargin) import Misc import Parser (parseExpressionThrows, parseProgramThrows) import Printer (printProgram')@@ -38,218 +38,27 @@ yamlPack = Yaml.decodeFileThrow spec :: Spec-spec = do- describe "filter packs" $ do- let resources = "test-resources/filter-packs"- packs <- runIO (allPathsIn resources)- forM_- packs- ( \pth -> it (makeRelative resources pth) $ do- YamlPack{..} <- yamlPack pth- prog <- parseProgramThrows program- included <- traverse parseExpressionThrows shown- excluded <- traverse parseExpressionThrows hidden- res <- parseProgramThrows result- let [(prog', _)] = F.exclude (F.include [(prog, Nothing)] included) excluded- prog' `shouldBe` res- when- (prog' /= res)- ( expectationFailure- ( "Expected:\n"- ++ printProgram' res (SALTY, UNICODE, MULTILINE)- ++ "\nbut got:\n"- ++ printProgram' prog' (SALTY, UNICODE, MULTILINE)- )- )- )-- describe "exclude with empty expression list" $- it "returns programs unchanged" $ do- prog <- parseProgramThrows "{[[ x -> Q ]]}"- let result = F.exclude [(prog, Nothing)] []- result `shouldBe` [(prog, Nothing)]-- describe "exclude with empty program list" $- it "returns empty list" $ do- fqn <- parseExpressionThrows "Q.x"- let result = F.exclude [] [fqn]- result `shouldBe` []-- describe "exclude with non-formation program" $- it "returns program unchanged" $ do- let prog = Program ExGlobal- fqn = ExDispatch ExGlobal (AtLabel "x")- result = F.exclude [(prog, Nothing)] [fqn]- result `shouldBe` [(prog, Nothing)]-- describe "exclude with termination program" $- it "returns program unchanged" $ do- let prog = Program ExTermination- fqn = ExDispatch ExGlobal (AtLabel "x")- result = F.exclude [(prog, Nothing)] [fqn]- result `shouldBe` [(prog, Nothing)]-- describe "exclude with non-dispatch FQN" $- it "handles non-dispatch expression gracefully" $ do- prog <- parseProgramThrows "{[[ x -> Q ]]}"- let fqn = ExGlobal- [(prog', _)] = F.exclude [(prog, Nothing)] [fqn]- prog' `shouldBe` prog-- describe "exclude with xi FQN" $- it "handles xi expression gracefully" $ do- prog <- parseProgramThrows "{[[ x -> Q ]]}"- let fqn = ExThis- [(prog', _)] = F.exclude [(prog, Nothing)] [fqn]- prog' `shouldBe` prog-- describe "exclude multiple programs" $- it "processes all programs in list" $ do- prog1 <- parseProgramThrows "{[[ x -> Q, y -> $ ]]}"- prog2 <- parseProgramThrows "{[[ a -> Q, b -> $ ]]}"- fqn <- parseExpressionThrows "Q.x"- let result = F.exclude [(prog1, Nothing), (prog2, Nothing)] [fqn]- length result `shouldBe` 2-- describe "include with empty expression list" $- it "returns programs unchanged" $ do- prog <- parseProgramThrows "{[[ x -> Q ]]}"- let result = F.include [(prog, Nothing)] []- result `shouldBe` [(prog, Nothing)]-- describe "include with empty program list" $- it "returns empty list" $ do- fqn <- parseExpressionThrows "Q.x"- let result = F.include [] [fqn]- result `shouldBe` []-- describe "include with non-formation program" $- it "returns empty formation" $ do- let prog = Program ExGlobal- fqn = ExDispatch ExGlobal (AtLabel "x")- [(prog', _)] = F.include [(prog, Nothing)] [fqn]- prog' `shouldBe` Program (ExFormation [BiVoid AtRho])-- describe "include with termination program" $- it "returns empty formation" $ do- let prog = Program ExTermination- fqn = ExDispatch ExGlobal (AtLabel "x")- [(prog', _)] = F.include [(prog, Nothing)] [fqn]- prog' `shouldBe` Program (ExFormation [BiVoid AtRho])-- describe "include with non-existent attribute" $- it "returns empty formation" $ do- prog <- parseProgramThrows "{[[ x -> Q ]]}"- fqn <- parseExpressionThrows "Q.nonexistent"- let [(prog', _)] = F.include [(prog, Nothing)] [fqn]- prog' `shouldBe` Program (ExFormation [BiVoid AtRho])-- describe "include with non-matching nested attribute" $- it "returns empty formation when path doesnt exist" $ do- prog <- parseProgramThrows "{[[ x -> [[ y -> Q ]] ]]}"- fqn <- parseExpressionThrows "Q.x.nonexistent"- let [(prog', _)] = F.include [(prog, Nothing)] [fqn]- prog' `shouldBe` Program (ExFormation [BiVoid AtRho])-- describe "include with non-dispatch FQN" $- it "handles non-dispatch expression gracefully" $ do- prog <- parseProgramThrows "{[[ x -> Q ]]}"- let fqn = ExGlobal- [(prog', _)] = F.include [(prog, Nothing)] [fqn]- prog' `shouldBe` Program (ExFormation [BiVoid AtRho])-- describe "include with xi FQN" $- it "handles xi expression gracefully" $ do- prog <- parseProgramThrows "{[[ x -> Q ]]}"- let fqn = ExThis- [(prog', _)] = F.include [(prog, Nothing)] [fqn]- prog' `shouldBe` Program (ExFormation [BiVoid AtRho])-- describe "include multiple programs" $- it "processes all programs in list" $ do- prog1 <- parseProgramThrows "{[[ x -> Q, y -> $ ]]}"- prog2 <- parseProgramThrows "{[[ a -> Q, b -> $ ]]}"- fqn <- parseExpressionThrows "Q.x"- let result = F.include [(prog1, Nothing), (prog2, Nothing)] [fqn]- length result `shouldBe` 2-- describe "include with nested formation not matching" $- it "skips non-matching bindings to find target" $ do- prog <- parseProgramThrows "{[[ a -> Q, x -> [[ y -> Q ]] ]]}"- fqn <- parseExpressionThrows "Q.x.y"- let [(prog', _)] = F.include [(prog, Nothing)] [fqn]- isFormation (Program (ExFormation _)) = True- isFormation _ = False- prog' `shouldSatisfy` isFormation-- describe "include with deep nested path" $- it "follows multi-level FQN" $ do- prog <- parseProgramThrows "{[[ a -> [[ b -> [[ c -> Q ]] ]] ]]}"- fqn <- parseExpressionThrows "Q.a.b.c"- let [(prog', _)] = F.include [(prog, Nothing)] [fqn]- isFormation (Program (ExFormation _)) = True- isFormation _ = False- prog' `shouldSatisfy` isFormation-- describe "exclude with deep nested path" $- it "removes from multi-level FQN" $ do- prog <- parseProgramThrows "{[[ a -> [[ b -> [[ c -> Q, d -> $ ]] ]] ]]}"- fqn <- parseExpressionThrows "Q.a.b.c"- let [(prog', _)] = F.exclude [(prog, Nothing)] [fqn]- isFormation (Program (ExFormation _)) = True- isFormation _ = False- prog' `shouldSatisfy` isFormation-- describe "exclude preserves rule metadata" $- it "keeps Nothing rule through exclude" $ do- prog <- parseProgramThrows "{[[ x -> Q ]]}"- fqn <- parseExpressionThrows "Q.y"- let [(_, rule)] = F.exclude [(prog, Nothing)] [fqn]- rule `shouldBe` Nothing-- describe "include preserves rule metadata" $- it "keeps Nothing rule through include" $ do- prog <- parseProgramThrows "{[[ x -> Q ]]}"- fqn <- parseExpressionThrows "Q.x"- let [(_, rule)] = F.include [(prog, Nothing)] [fqn]- rule `shouldBe` Nothing-- describe "exclude with non-formation nested binding" $- it "handles tau with non-formation value" $ do- prog <- parseProgramThrows "{[[ x -> Q ]]}"- fqn <- parseExpressionThrows "Q.x.y"- let [(prog', _)] = F.exclude [(prog, Nothing)] [fqn]- prog' `shouldBe` prog-- describe "include with formation lacking target binding" $- it "returns empty formation when binding not found" $ do- prog <- parseProgramThrows "{[[ x -> [[ a -> Q ]] ]]}"- fqn <- parseExpressionThrows "Q.y.z"- let [(prog', _)] = F.include [(prog, Nothing)] [fqn]- prog' `shouldBe` Program (ExFormation [BiVoid AtRho])-- describe "exclude with void binding" $- it "handles void bindings correctly" $ do- prog <- parseProgramThrows "{[[ x -> ?, y -> Q ]]}"- fqn <- parseExpressionThrows "Q.x"- let [(prog', _)] = F.exclude [(prog, Nothing)] [fqn]- Program (ExFormation bds) = prog'- length bds `shouldBe` 2-- describe "exclude with meta binding" $- it "handles meta bindings correctly" $ do- let prog = Program (ExFormation [BiMeta "B", BiTau (AtLabel "x") ExGlobal])- fqn = ExDispatch ExGlobal (AtLabel "x")- [(prog', _)] = F.exclude [(prog, Nothing)] [fqn]- Program (ExFormation bds) = prog'- length bds `shouldBe` 1-- describe "include uses only first FQN" $- it "ignores additional FQNs in list" $ do- prog <- parseProgramThrows "{[[ x -> Q, y -> $ ]]}"- fqn1 <- parseExpressionThrows "Q.x"- fqn2 <- parseExpressionThrows "Q.y"- let [(prog', _)] = F.include [(prog, Nothing)] [fqn1, fqn2]- Program (ExFormation bds) = prog'- names = [attr | BiTau attr _ <- bds]- AtLabel "x" `elem` names `shouldBe` True+spec = describe "filter packs" $ do+ let resources = "test-resources/filter-packs"+ packs <- runIO (allPathsIn resources)+ forM_+ packs+ ( \pth -> it (makeRelative resources pth) $ do+ YamlPack{..} <- yamlPack pth+ prog <- parseProgramThrows program+ included <- traverse parseExpressionThrows shown+ excluded <- traverse parseExpressionThrows hidden+ res <- parseProgramThrows result+ let [(prog', _)] = F.exclude (F.include [(prog, Nothing)] included) excluded+ cfg = (SALTY, UNICODE, MULTILINE, defaultMargin)+ prog' `shouldBe` res+ when+ (prog' /= res)+ ( expectationFailure+ ( "Expected:\n"+ ++ printProgram' res cfg+ ++ "\nbut got:\n"+ ++ printProgram' prog' cfg+ )+ )+ )
test/PrinterSpec.hs view
@@ -9,10 +9,9 @@ import AST import Control.Monad (forM_)-import Data.Map.Strict qualified as Map import Encoding (Encoding (..)) import Lining (LineFormat (..))-import Matcher (MetaValue (..), Subst (..), Tail (..), defaultScope)+import Margin (defaultMargin) import Printer import Sugar (SugarType (..)) import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)@@ -25,65 +24,23 @@ [ ("ξ renders as $", ExThis, "$") , ("Φ renders as Q", ExGlobal, "Q") , ("⊥ renders as T", ExTermination, "T")- ]- ( \(desc, expr, expected) ->- it desc (printExpression' expr (SWEET, ASCII, SINGLELINE) `shouldBe` expected)- )-- describe "printExpression with ASCII singleline renders formation with void" $- forM_- [ ("ρ void becomes empty", ExFormation [BiVoid AtRho], "[[]]")+ , ("ρ void becomes empty", ExFormation [BiVoid AtRho], "[[]]") , ("φ void", ExFormation [BiVoid AtPhi], "[[ @ -> ? ]]") , ("label void", ExFormation [BiVoid (AtLabel "名前")], "[[ 名前 -> ? ]]")- ]- ( \(desc, expr, expected) ->- it desc (printExpression' expr (SWEET, ASCII, SINGLELINE) `shouldBe` expected)- )-- describe "printExpression with ASCII singleline renders formation with tau" $- forM_- [ ("x to Φ", ExFormation [BiTau (AtLabel "x") ExGlobal], "[[ x -> Q ]]")+ , ("x to Φ", ExFormation [BiTau (AtLabel "x") ExGlobal], "[[ x -> Q ]]") , ("α0 to ξ", ExFormation [BiTau (AtAlpha 0) ExThis], "[[ ~0 -> $ ]]") , ("ρ to ⊥", ExFormation [BiTau AtRho ExTermination], "[[ ^ -> T ]]")- ]- ( \(desc, expr, expected) ->- it desc (printExpression' expr (SWEET, ASCII, SINGLELINE) `shouldBe` expected)- )-- describe "printExpression with ASCII singleline renders formation with delta" $- forM_- [ ("empty delta", ExFormation [BiDelta BtEmpty], "[[ D> -- ]]")+ , ("empty delta", ExFormation [BiDelta BtEmpty], "[[ D> -- ]]") , ("single byte", ExFormation [BiDelta (BtOne "1F")], "[[ D> 1F- ]]") , ("multiple bytes", ExFormation [BiDelta (BtMany ["00", "01", "02"])], "[[ D> 00-01-02 ]]")- ]- ( \(desc, expr, expected) ->- it desc (printExpression' expr (SWEET, ASCII, SINGLELINE) `shouldBe` expected)- )-- describe "printExpression with ASCII singleline renders formation with lambda" $- forM_- [ ("función lambda", ExFormation [BiLambda "Función"], "[[ L> Función ]]")+ , ("función lambda", ExFormation [BiLambda "Función"], "[[ L> Función ]]") , ("クラス lambda", ExFormation [BiLambda "クラス"], "[[ L> クラス ]]")- ]- ( \(desc, expr, expected) ->- it desc (printExpression' expr (SWEET, ASCII, SINGLELINE) `shouldBe` expected)- )-- describe "printExpression with ASCII singleline renders dispatch" $- forM_- [ ("Φ.org", ExDispatch ExGlobal (AtLabel "org"), "Q.org")+ , ("Φ.org", ExDispatch ExGlobal (AtLabel "org"), "Q.org") , ("ξ.ρ as sugar", ExDispatch ExThis AtRho, "^") , ("ξ.φ as sugar", ExDispatch ExThis AtPhi, "@") , ("chained dispatch", ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "éolang"), "Q.org.éolang") , ("ξ.α0 as sugar", ExDispatch ExThis (AtAlpha 0), "~0")- ]- ( \(desc, expr, expected) ->- it desc (printExpression' expr (SWEET, ASCII, SINGLELINE) `shouldBe` expected)- )-- describe "printExpression with ASCII singleline renders application" $- forM_- [+ , ( "dispatch with app" , ExApplication (ExDispatch ExGlobal (AtLabel "x")) (BiTau (AtLabel "y") ExThis) , "Q.x( y -> $ )"@@ -93,28 +50,14 @@ , ExApplication (ExFormation [BiVoid AtRho]) (BiTau (AtAlpha 0) ExGlobal) , "[[]]( Q )" )- ]- ( \(desc, expr, expected) ->- it desc (printExpression' expr (SWEET, ASCII, SINGLELINE) `shouldBe` expected)- )-- describe "printExpression with ASCII singleline renders meta expressions" $- forM_- [ ("meta expr", ExMeta "e", "!e")+ , ("meta expr", ExMeta "e", "!e") , ("meta tail", ExMetaTail ExGlobal "t", "Q * !t")- ]- ( \(desc, expr, expected) ->- it desc (printExpression' expr (SWEET, ASCII, SINGLELINE) `shouldBe` expected)- )-- describe "printExpression with ASCII singleline renders meta bindings" $- forM_- [ ("meta binding", ExFormation [BiMeta "B"], "[[ !B ]]")+ , ("meta binding", ExFormation [BiMeta "B"], "[[ !B ]]") , ("meta lambda", ExFormation [BiMetaLambda "F"], "[[ L> !F ]]") , ("meta attr tau", ExFormation [BiTau (AtMeta "a") ExThis], "[[ !a -> $ ]]") ] ( \(desc, expr, expected) ->- it desc (printExpression' expr (SWEET, ASCII, SINGLELINE) `shouldBe` expected)+ it desc (printExpression' expr (SWEET, ASCII, SINGLELINE, defaultMargin) `shouldBe` expected) ) describe "printProgram with default config" $@@ -139,16 +82,6 @@ it desc (printAttribute attr `shouldBe` expected) ) - describe "printAttribute in ASCII dispatch expression with sugar" $- forM_- [ ("ρ as caret", AtRho, "^")- , ("φ as at", AtPhi, "@")- , ("αN as tildeN", AtAlpha 42, "~42")- ]- ( \(desc, attr, expected) ->- it desc (printExpression' (ExDispatch ExThis attr) (SWEET, ASCII, SINGLELINE) `shouldBe` expected)- )- describe "printBinding renders as formation" $ forM_ [ ("tau binding", BiTau (AtLabel "x") ExGlobal, "x ↦ Φ")@@ -180,65 +113,3 @@ ( \(desc, arg, expected) -> it desc (printExtraArg arg `shouldContain` expected) )-- describe "printSubsts renders empty list" $- it "returns separator" $- printSubsts [] `shouldBe` "------"-- describe "printSubsts renders attribute substitution" $- it "contains key and value" $- printSubsts [Subst (Map.singleton "α" (MvAttribute (AtLabel "ατρ")))]- `shouldContain` "α >> ατρ"-- describe "printSubsts renders multiple substitutions" $- it "separates with dashed line" $- let substs =- [ Subst (Map.singleton "a" (MvAttribute AtRho))- , Subst (Map.singleton "b" (MvAttribute AtPhi))- ]- in printSubsts substs `shouldContain` "------"-- describe "printSubsts renders expression value" $- it "contains expression" $- printSubsts [Subst (Map.singleton "e" (MvExpression ExGlobal defaultScope))]- `shouldContain` "e >> Φ"-- describe "printSubsts renders bindings value" $- it "contains bindings header" $- printSubsts [Subst (Map.singleton "B" (MvBindings [BiVoid (AtLabel "x")]))]- `shouldContain` "B >> ⟦"-- describe "printSubsts renders bytes value" $- it "contains bytes" $- printSubsts [Subst (Map.singleton "d" (MvBytes (BtMany ["AB", "CD"])))]- `shouldContain` "d >> AB-CD"-- describe "printSubsts renders function value" $- it "contains function name" $- printSubsts [Subst (Map.singleton "F" (MvFunction "MyFunc"))]- `shouldContain` "F >> MyFunc"-- describe "printSubsts renders tail value with dispatch" $- it "contains dispatch" $- printSubsts [Subst (Map.singleton "t" (MvTail [TaDispatch (AtLabel "attr")]))]- `shouldContain` "t >> .attr"-- describe "printSubsts renders tail value with application" $- it "contains application" $- printSubsts [Subst (Map.singleton "t" (MvTail [TaApplication (BiTau (AtLabel "x") ExThis)]))]- `shouldContain` "(⟦"-- describe "printExpression with salty config" $- it "adds explicit rho binding" $- printExpression' (ExFormation [BiVoid (AtLabel "x")]) (SALTY, UNICODE, SINGLELINE)- `shouldContain` "ρ ↦ ∅"-- describe "printExpression with multiline format" $- it "adds newlines in formation" $- let expr = ExFormation [BiTau (AtLabel "x") ExGlobal, BiVoid (AtLabel "y")]- result = printExpression' expr (SWEET, UNICODE, MULTILINE)- in result `shouldContain` "\n"-- describe "logPrintConfig" $- it "is sweet unicode singleline" $- logPrintConfig `shouldBe` (SWEET, UNICODE, SINGLELINE)
test/XMIRSpec.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT@@ -8,23 +9,20 @@ module XMIRSpec where import AST-import Control.Exception (bracket)-import Control.Monad (filterM, forM_, unless)+import Control.Monad (forM_, unless) import Data.Aeson+import Data.Char (isDigit) import Data.List (intercalate)+import Data.Text qualified as T import Data.Yaml qualified as Yaml import GHC.Generics (Generic)-import GHC.IO (unsafePerformIO) import Misc (allPathsIn) import Parser (parseExpressionThrows, parseProgramThrows)-import System.Directory (removeFile)-import System.Exit (ExitCode (ExitSuccess)) import System.FilePath (makeRelative)-import System.IO (hClose, hPutStr, openTempFile)-import System.Info (os)-import System.Process (readProcessWithExitCode)-import Test.Hspec (Spec, anyException, describe, expectationFailure, it, pendingWith, runIO, shouldBe, shouldThrow)-import XMIR (defaultXmirContext, parseXMIRThrows, printXMIR, programToXMIR, xmirToPhi)+import Test.Hspec (Spec, anyException, describe, expectationFailure, it, runIO, shouldBe, shouldThrow)+import Text.XML (Document (..), Element (..))+import Text.XML.Cursor qualified as C+import XMIR (defaultXmirContext, parseXMIRThrows, printXMIR, programToXMIR, toName, xmirToPhi) data ParsePack = ParsePack { failure :: Maybe Bool@@ -45,16 +43,148 @@ printPack :: FilePath -> IO PrintPack printPack = Yaml.decodeFileThrow --- Check if xmllint is available on the system-isXmllintAvailable :: Bool-isXmllintAvailable =- let (exitCode, _, _) = unsafePerformIO (readProcessWithExitCode "xmllint" ["--version"] "")- in (exitCode == ExitSuccess)+-- | An XPath predicate that filters cursors.+data Predicate+ = AttrEquals String String+ | ChildText String String+ | ChildExists String [Predicate]+ | PositionIs Int+ | AndPred Predicate Predicate+ deriving (Show) --- Check if running on Windows-isWindows :: Bool-isWindows = os == "mingw32"+-- | An XPath step with element name and predicates.+data Step = Step String [Predicate]+ deriving (Show) +{- | Parse a simple XPath expression into steps.+Supports: /element/element[@attr="val" and child="val" and child[N][@attr="val"]]+-}+xpath :: String -> [Step]+xpath ('/' : rest) = steps rest+xpath _ = []++steps :: String -> [Step]+steps "" = []+steps str =+ let (step, rest) = span (\c -> c /= '/' && c /= '[') str+ (preds, remaining) = parsePredicate rest+ in Step step preds : steps (dropWhile (== '/') remaining)++parsePredicate :: String -> ([Predicate], String)+parsePredicate ('[' : rest) =+ let (inner, after) = splitBracket rest+ pred' = parsePredicateInner inner+ (more, final) = parsePredicate after+ in (pred' : more, final)+parsePredicate str = ([], str)++splitBracket :: String -> (String, String)+splitBracket = go (0 :: Int) ""+ where+ go :: Int -> String -> String -> (String, String)+ go _ acc "" = (reverse acc, "")+ go 0 acc (']' : rest) = (reverse acc, rest)+ go n acc ('[' : rest) = go (n + 1) ('[' : acc) rest+ go n acc (']' : rest) = go (n - 1) (']' : acc) rest+ go n acc (c : rest) = go n (c : acc) rest++parsePredicateInner :: String -> Predicate+parsePredicateInner str+ | " and " `isInfixOf'` str =+ let parts = splitAnd str+ in foldr1 AndPred (map parsePredicateInner parts)+ | all isDigit str = PositionIs (read str)+ | '@' : rest <- str = parseAttrPred rest+ | otherwise = parseChildPred str+ where+ isInfixOf' needle haystack = needle `elem` tails haystack+ tails [] = [[]]+ tails s@(_ : xs) = s : tails xs++splitAnd :: String -> [String]+splitAnd = go (0 :: Int) ""+ where+ go :: Int -> String -> String -> [String]+ go _ acc "" = [reverse acc | not (null acc)]+ go n acc ('[' : rest) = go (n + 1) ('[' : acc) rest+ go n acc (']' : rest) = go (n - 1) (']' : acc) rest+ go 0 acc (' ' : 'a' : 'n' : 'd' : ' ' : rest) = reverse acc : go 0 "" rest+ go n acc (c : rest) = go n (c : acc) rest++parseAttrPred :: String -> Predicate+parseAttrPred str =+ let (name, rest) = break (== '=') str+ val = extractQuoted (drop 1 rest)+ in AttrEquals name val++parseChildPred :: String -> Predicate+parseChildPred str+ | '[' `elem` str =+ let (name, rest) = break (== '[') str+ (preds, _) = parsePredicate rest+ in ChildExists name preds+ | '=' `elem` str =+ let (name, rest) = break (== '=') str+ val = extractQuoted (drop 1 rest)+ in ChildText name val+ | otherwise = ChildExists str []++extractQuoted :: String -> String+extractQuoted (q : rest)+ | q == '"' || q == '\'' = takeWhile (/= q) rest+extractQuoted s = s++{- | Evaluate an XPath expression on a document, returning matched cursors.+Note: fromDocument returns cursor at root element, so first step must match root.+-}+evaluate :: Document -> [Step] -> [C.Cursor]+evaluate doc [] = [C.fromDocument doc]+evaluate doc (Step name preds : rest) =+ let root = C.fromDocument doc+ rootName = elementName (documentRoot doc)+ in if rootName == toName name+ then foldl applyStep (applyPredicates [root] preds) rest+ else []++applyStep :: [C.Cursor] -> Step -> [C.Cursor]+applyStep curs (Step name preds) = do+ cur <- curs+ child <- cur C.$/ C.element (toName name)+ applyPredicates [child] preds++applyPredicates :: [C.Cursor] -> [Predicate] -> [C.Cursor]+applyPredicates = foldl applyPredicate++applyPredicate :: [C.Cursor] -> Predicate -> [C.Cursor]+applyPredicate curs pred' = case pred' of+ AttrEquals name val -> filter (hasAttrValue name val) curs+ ChildText name val -> filter (hasChildText name val) curs+ ChildExists name nested -> filter (hasChild name nested) curs+ PositionIs n -> take 1 (drop (n - 1) curs)+ AndPred p1 p2 -> applyPredicate (applyPredicate curs p1) p2++hasAttrValue :: String -> String -> C.Cursor -> Bool+hasAttrValue name val cur = C.attribute (toName name) cur == [T.pack val]++hasChildText :: String -> String -> C.Cursor -> Bool+hasChildText name val cur =+ let children = cur C.$/ C.element (toName name)+ in any (hasTextContent val) children++hasTextContent :: String -> C.Cursor -> Bool+hasTextContent val cur =+ let txt = concatMap T.unpack (cur C.$/ C.content)+ in txt == val++hasChild :: String -> [Predicate] -> C.Cursor -> Bool+hasChild name nested cur =+ let children = cur C.$/ C.element (toName name)+ in not (null (applyPredicates children nested))++-- | Check if an XPath expression matches anything in the document.+matches :: Document -> String -> Bool+matches doc path = not (null (evaluate doc (xpath path)))+ spec :: Spec spec = do describe "XMIR parsing packs" $ do@@ -94,38 +224,17 @@ describe "XMIR printing packs" $ do let resources = "test-resources/xmir-printing-packs"- available = isXmllintAvailable packs <- runIO (allPathsIn resources) forM_ packs ( \pth ->- it (makeRelative resources pth) $- if isWindows- then pendingWith "Skipped on Windows due to xmllint Unicode issues"- else- if not available- then pendingWith "The 'xmllint' is not available"- else do- pack <- printPack pth- let PrintPack{phi = phi', xpaths = xpaths'} = pack- prog <- parseProgramThrows phi'- xmir' <- programToXMIR prog defaultXmirContext- let xml = printXMIR xmir'- bracket- (openTempFile "." "xmirXXXXXX.tmp")- (\(fp, _) -> removeFile fp)- ( \(path, hTmp) -> do- hPutStr hTmp xml- hClose hTmp- failed <-- filterM- ( \xpath -> do- (code, _, _) <- readProcessWithExitCode "xmllint" ["--xpath", xpath, path] ""- pure (code /= ExitSuccess)- )- xpaths'- unless- (null failed)- (expectationFailure ("Failed xpaths:\n - " ++ intercalate "\n - " failed ++ "\nXMIR is:\n" ++ xml))- )+ it (makeRelative resources pth) $ do+ pack <- printPack pth+ let PrintPack{phi = phi', xpaths = xpaths'} = pack+ prog <- parseProgramThrows phi'+ xmir' <- programToXMIR prog defaultXmirContext+ let failed = filter (not . matches xmir') xpaths'+ unless+ (null failed)+ (expectationFailure ("Failed xpaths:\n - " ++ intercalate "\n - " failed ++ "\nXMIR is:\n" ++ printXMIR xmir')) )