From 34bc4733f1c38208cc088edd1385ad389dba1bc6 Mon Sep 17 00:00:00 2001 From: Clemens Schmid Date: Sat, 25 Nov 2023 13:38:47 +0100 Subject: [PATCH 1/6] some simplifications for the non-permutation argument parser --- src/Currycarbon/ParserHelpers.hs | 16 ++++++++-------- src/Currycarbon/Parsers.hs | 9 +++------ 2 files changed, 11 insertions(+), 14 deletions(-) diff --git a/src/Currycarbon/ParserHelpers.hs b/src/Currycarbon/ParserHelpers.hs index 9e3af13..ab5a249 100644 --- a/src/Currycarbon/ParserHelpers.hs +++ b/src/Currycarbon/ParserHelpers.hs @@ -22,18 +22,18 @@ parseVector parser = do -- * Low level blocks -parseOptionalArgumentComma :: String -> P.Parser b -> P.Parser (Maybe b) -parseOptionalArgumentComma argumentName parseValue = - P.optionMaybe $ P.try (parseArgumentComma argumentName parseValue) +parseArgumentOptional :: String -> P.Parser b -> P.Parser (Maybe b) +parseArgumentOptional argumentName parseValue = + P.optionMaybe $ P.try (parseArgument argumentName parseValue) -parseArgumentComma :: String -> P.Parser b -> P.Parser b -parseArgumentComma argumentName parseValue = do - res <- parseArgument argumentName parseValue +parseArgument :: String -> P.Parser b -> P.Parser b +parseArgument argumentName parseValue = do + res <- parseArgumentWithoutComma argumentName parseValue P.optional consumeCommaSep return res -parseArgument :: String -> P.Parser b -> P.Parser b -parseArgument argumentName parseValue = +parseArgumentWithoutComma :: String -> P.Parser b -> P.Parser b +parseArgumentWithoutComma argumentName parseValue = P.try parseNamedArgument P.<|> parseUnnamedArgument where parseNamedArgument = do diff --git a/src/Currycarbon/Parsers.hs b/src/Currycarbon/Parsers.hs index 8e920e2..020ad28 100644 --- a/src/Currycarbon/Parsers.hs +++ b/src/Currycarbon/Parsers.hs @@ -110,12 +110,9 @@ renderTimeWindowBCAD (TimeWindowBCAD name start stop) = parseTimeWindowBP :: P.Parser TimeWindowBP parseTimeWindowBP = do parseRecordType "rangeBP" $ do - -- name <- P.optional $ P.try $ do - -- parseArgument "name" parseAnyString - -- consumeCommaSepname - name <- parseArgumentComma "name" parseAnyString - start <- parseArgumentComma "start" parseWord - stop <- parseArgumentComma "stop" parseWord + name <- parseArgument "name" parseAnyString + start <- parseArgument "start" parseWord + stop <- parseArgument "stop" parseWord if start >= stop then return (TimeWindowBP name start stop) else fail "the BP stop date can not be larger than the start date" From f3df2f9720aa14e77769f9809547346035bec431 Mon Sep 17 00:00:00 2001 From: Clemens Schmid Date: Sat, 25 Nov 2023 14:14:34 +0100 Subject: [PATCH 2/6] modernizing more parsers --- src/Currycarbon/ParserHelpers.hs | 16 +++++++++------ src/Currycarbon/Parsers.hs | 34 ++++++++++++++------------------ 2 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/Currycarbon/ParserHelpers.hs b/src/Currycarbon/ParserHelpers.hs index ab5a249..1b4f456 100644 --- a/src/Currycarbon/ParserHelpers.hs +++ b/src/Currycarbon/ParserHelpers.hs @@ -20,7 +20,9 @@ parseVector parser = do _ <- P.char 'c' parseInParens (P.sepBy parser consumeCommaSep) --- * Low level blocks +parseArgumentWithDefault :: String -> P.Parser b -> b -> P.Parser b +parseArgumentWithDefault argumentName parseValue defaultValue = + P.option defaultValue (parseArgument argumentName parseValue) parseArgumentOptional :: String -> P.Parser b -> P.Parser (Maybe b) parseArgumentOptional argumentName parseValue = @@ -32,6 +34,8 @@ parseArgument argumentName parseValue = do P.optional consumeCommaSep return res +-- * Low level blocks + parseArgumentWithoutComma :: String -> P.Parser b -> P.Parser b parseArgumentWithoutComma argumentName parseValue = P.try parseNamedArgument P.<|> parseUnnamedArgument @@ -75,7 +79,7 @@ parseAnyString = where inDoubleQuotes = P.between (P.char '"') (P.char '"') (P.many P.anyChar) inSingleQuotes = P.between (P.char '\'') (P.char '\'') (P.many P.anyChar) - inNoQuotes = P.many (P.noneOf ",") + inNoQuotes = P.many (P.noneOf ",)") -- * Sequence parsers @@ -115,15 +119,15 @@ parsePositiveFloatNumber = do parseIntegerSequence :: P.Parser [Int] parseIntegerSequence = do - start <- parseInteger + start <- parseInt _ <- P.oneOf ":" - stop <- parseInteger + stop <- parseInt _ <- P.oneOf ":" by <- fromIntegral <$> parsePositiveInt return [start,(start+by)..stop] -parseInteger :: P.Parser Int -parseInteger = do +parseInt :: P.Parser Int +parseInt = do P.try parseNegativeInt P.<|> parsePositiveInt parseNegativeInt :: P.Parser Int diff --git a/src/Currycarbon/Parsers.hs b/src/Currycarbon/Parsers.hs index 020ad28..bb11279 100644 --- a/src/Currycarbon/Parsers.hs +++ b/src/Currycarbon/Parsers.hs @@ -119,14 +119,13 @@ parseTimeWindowBP = do parseTimeWindowBCAD :: P.Parser TimeWindowBCAD parseTimeWindowBCAD = do - name <- P.many (P.noneOf ",") - _ <- parseCharInSpace ',' - start <- parseInteger - _ <- P.spaces *> P.string "-+-" <* P.spaces - stop <- parseInteger - if start <= stop - then return (TimeWindowBCAD name start stop) - else fail "the BC/AD stop date can not be smaller than the start date" + parseRecordType "rangeBCAD" $ do + name <- parseArgument "name" parseAnyString + start <- parseArgument "start" parseInt + stop <- parseArgument "stop" parseInt + if start <= stop + then return (TimeWindowBCAD name start stop) + else fail "the BC/AD stop date can not be smaller than the start date" add :: P.Parser CalExpr add = SumCal <$> term <*> (parseCharInSpace '+' *> expr) @@ -218,20 +217,17 @@ readUncalC14 s = parseUncalC14 :: P.Parser UncalC14 parseUncalC14 = do - P.try long P.<|> short + parseRecordType "uncalC14" $ P.try long P.<|> short where long = do - name <- P.many (P.noneOf ",") - _ <- P.oneOf "," - mean <- parseWord - _ <- P.oneOf "," - std <- parseWord - return (UncalC14 name mean std) + name <- parseArgument "name" parseAnyString + age <- parseArgument "age" parseWord + sigma <- parseArgument "sigma" parseWord + return (UncalC14 name age sigma) short = do - mean <- parseWord - _ <- P.oneOf "," - std <- parseWord - return (UncalC14 "unknownSampleName" mean std) + age <- parseArgument "age" parseWord + sigma <- parseArgument "sigma" parseWord + return (UncalC14 "unknownSampleName" age sigma) -- CalC14 -- | Write 'CalC14's to the file system. The output file is a long .csv file with the following structure: From bef4a1e60422941fe2371471a85614a1482000df Mon Sep 17 00:00:00 2001 From: Clemens Schmid Date: Sat, 25 Nov 2023 15:25:42 +0100 Subject: [PATCH 3/6] update of language logic to allow the use of functions for add and multiply --- src/Currycarbon/Parsers.hs | 63 ++++++++++++++++++++++---------------- 1 file changed, 37 insertions(+), 26 deletions(-) diff --git a/src/Currycarbon/Parsers.hs b/src/Currycarbon/Parsers.hs index bb11279..724cf50 100644 --- a/src/Currycarbon/Parsers.hs +++ b/src/Currycarbon/Parsers.hs @@ -108,45 +108,57 @@ renderTimeWindowBCAD (TimeWindowBCAD name start stop) = -- https://gist.github.com/abhin4v/017a36477204a1d57745 parseTimeWindowBP :: P.Parser TimeWindowBP -parseTimeWindowBP = do - parseRecordType "rangeBP" $ do - name <- parseArgument "name" parseAnyString - start <- parseArgument "start" parseWord - stop <- parseArgument "stop" parseWord - if start >= stop - then return (TimeWindowBP name start stop) - else fail "the BP stop date can not be larger than the start date" +parseTimeWindowBP = parseRecordType "rangeBP" $ do + name <- parseArgument "name" parseAnyString + start <- parseArgument "start" parseWord + stop <- parseArgument "stop" parseWord + if start >= stop + then return (TimeWindowBP name start stop) + else fail "the BP stop date can not be larger than the start date" parseTimeWindowBCAD :: P.Parser TimeWindowBCAD -parseTimeWindowBCAD = do - parseRecordType "rangeBCAD" $ do - name <- parseArgument "name" parseAnyString - start <- parseArgument "start" parseInt - stop <- parseArgument "stop" parseInt - if start <= stop - then return (TimeWindowBCAD name start stop) - else fail "the BC/AD stop date can not be smaller than the start date" - -add :: P.Parser CalExpr -add = SumCal <$> term <*> (parseCharInSpace '+' *> expr) - -mul :: P.Parser CalExpr -mul = ProductCal <$> factor <*> (parseCharInSpace '*' *> term) +parseTimeWindowBCAD = parseRecordType "rangeBCAD" $ do + name <- parseArgument "name" parseAnyString + start <- parseArgument "start" parseInt + stop <- parseArgument "stop" parseInt + if start <= stop + then return (TimeWindowBCAD name start stop) + else fail "the BC/AD stop date can not be smaller than the start date" + +addFun :: P.Parser CalExpr +addFun = parseRecordType "add" $ do + a <- parseArgument "a" term + b <- parseArgument "b" expr + return $ SumCal a b + +addOperator :: P.Parser CalExpr +addOperator = SumCal <$> term <*> (parseCharInSpace '+' *> expr) + +mulFun :: P.Parser CalExpr +mulFun = parseRecordType "mul" $ do + a <- parseArgument "a" factor + b <- parseArgument "b" term + return $ ProductCal a b + +mulOperator :: P.Parser CalExpr +mulOperator = ProductCal <$> factor <*> (parseCharInSpace '*' *> term) parens :: P.Parser CalExpr parens = P.between (parseCharInSpace '(') (parseCharInSpace ')') expr factor :: P.Parser CalExpr factor = P.try parens + P.<|> P.try addFun + P.<|> P.try mulFun P.<|> P.try (WindowBP <$> parseTimeWindowBP) P.<|> P.try (WindowBCAD <$> parseTimeWindowBCAD) P.<|> (UnCalDate <$> parseUncalC14) term :: P.Parser CalExpr -term = P.try mul P.<|> factor +term = P.try mulOperator P.<|> factor expr :: P.Parser CalExpr -expr = P.try add P.<|> term -- <* P.eof +expr = P.try addOperator P.<|> term -- <* P.eof namedExpr :: P.Parser NamedCalExpr namedExpr = do @@ -216,8 +228,7 @@ readUncalC14 s = uncalC14SepBySemicolon = P.sepBy parseUncalC14 (P.char ';' <* P.spaces) <* P.eof parseUncalC14 :: P.Parser UncalC14 -parseUncalC14 = do - parseRecordType "uncalC14" $ P.try long P.<|> short +parseUncalC14 = parseRecordType "uncalC14" $ P.try long P.<|> short where long = do name <- parseArgument "name" parseAnyString From 4d5ce9fed142aaffb4669cca0268c95ac04ad158 Mon Sep 17 00:00:00 2001 From: Clemens Schmid Date: Sat, 25 Nov 2023 15:39:05 +0100 Subject: [PATCH 4/6] better rendering --- src/Currycarbon/Parsers.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Currycarbon/Parsers.hs b/src/Currycarbon/Parsers.hs index 724cf50..801a164 100644 --- a/src/Currycarbon/Parsers.hs +++ b/src/Currycarbon/Parsers.hs @@ -4,7 +4,6 @@ module Currycarbon.Parsers where import Currycarbon.Types import Currycarbon.Utils -import Currycarbon.Calibration.Utils import Currycarbon.ParserHelpers import Control.Exception (throwIO) @@ -100,13 +99,12 @@ renderCalExpr (ProductCal a b) = "(" ++ renderCalExpr a ++ " * " ++ r renderTimeWindowBP :: TimeWindowBP -> String renderTimeWindowBP (TimeWindowBP name start stop) = - name ++ ":" ++ renderYearBP start ++ " --- " ++ renderYearBP stop + name ++ ":" ++ renderYearBP start ++ "-" ++ renderYearBP stop renderTimeWindowBCAD :: TimeWindowBCAD -> String renderTimeWindowBCAD (TimeWindowBCAD name start stop) = - name ++ ":" ++ renderYearBCAD start ++ " -+- " ++ renderYearBCAD stop + name ++ ":" ++ renderYearBCAD start ++ "-" ++ renderYearBCAD stop --- https://gist.github.com/abhin4v/017a36477204a1d57745 parseTimeWindowBP :: P.Parser TimeWindowBP parseTimeWindowBP = parseRecordType "rangeBP" $ do name <- parseArgument "name" parseAnyString @@ -125,6 +123,7 @@ parseTimeWindowBCAD = parseRecordType "rangeBCAD" $ do then return (TimeWindowBCAD name start stop) else fail "the BC/AD stop date can not be smaller than the start date" +-- https://gist.github.com/abhin4v/017a36477204a1d57745 addFun :: P.Parser CalExpr addFun = parseRecordType "add" $ do a <- parseArgument "a" term @@ -305,7 +304,7 @@ renderCalRangeSummary s = -- BP renderYearBP :: YearBP -> String renderYearBP x = - show x ++ "BP" ++ " (" ++ (renderYearBCAD $ bp2BCAD x) ++ ")" + show x ++ "BP" -- ++ " (" ++ (renderYearBCAD $ bp2BCAD x) ++ ")" -- BCAD renderYearBCAD :: YearBCAD -> String From dea01c5b0e834f258a6aef33f548be458bb3e456 Mon Sep 17 00:00:00 2001 From: Clemens Schmid Date: Sat, 25 Nov 2023 16:36:43 +0100 Subject: [PATCH 5/6] a flexible parser for named cal expressions --- src/Currycarbon/ParserHelpers.hs | 19 +++++++++++++------ src/Currycarbon/Parsers.hs | 18 ++++++++++++------ 2 files changed, 25 insertions(+), 12 deletions(-) diff --git a/src/Currycarbon/ParserHelpers.hs b/src/Currycarbon/ParserHelpers.hs index 1b4f456..b624bfc 100644 --- a/src/Currycarbon/ParserHelpers.hs +++ b/src/Currycarbon/ParserHelpers.hs @@ -34,16 +34,23 @@ parseArgument argumentName parseValue = do P.optional consumeCommaSep return res +parseNamedArgumentOptional :: String -> P.Parser b -> P.Parser (Maybe b) +parseNamedArgumentOptional argumentName parseValue = + P.optionMaybe $ P.try (parseNamedArgument argumentName parseValue) + -- * Low level blocks parseArgumentWithoutComma :: String -> P.Parser b -> P.Parser b parseArgumentWithoutComma argumentName parseValue = - P.try parseNamedArgument P.<|> parseUnnamedArgument - where - parseNamedArgument = do - (_,b) <- parseKeyValuePair (P.string argumentName) parseValue - return b - parseUnnamedArgument = parseValue + P.try (parseNamedArgument argumentName parseValue) P.<|> parseUnnamedArgument parseValue + +parseNamedArgument :: String -> P.Parser b -> P.Parser b +parseNamedArgument argumentName parseValue = do + (_,b) <- parseKeyValuePair (P.string argumentName) parseValue + return b + +parseUnnamedArgument :: P.Parser b -> P.Parser b +parseUnnamedArgument parseValue = parseValue parseKeyValuePair :: P.Parser a -> P.Parser b -> P.Parser (a,b) parseKeyValuePair parseKey parseValue = do diff --git a/src/Currycarbon/Parsers.hs b/src/Currycarbon/Parsers.hs index 801a164..beda8f8 100644 --- a/src/Currycarbon/Parsers.hs +++ b/src/Currycarbon/Parsers.hs @@ -125,7 +125,7 @@ parseTimeWindowBCAD = parseRecordType "rangeBCAD" $ do -- https://gist.github.com/abhin4v/017a36477204a1d57745 addFun :: P.Parser CalExpr -addFun = parseRecordType "add" $ do +addFun = parseRecordType "sum" $ do a <- parseArgument "a" term b <- parseArgument "b" expr return $ SumCal a b @@ -134,7 +134,7 @@ addOperator :: P.Parser CalExpr addOperator = SumCal <$> term <*> (parseCharInSpace '+' *> expr) mulFun :: P.Parser CalExpr -mulFun = parseRecordType "mul" $ do +mulFun = parseRecordType "product" $ do a <- parseArgument "a" factor b <- parseArgument "b" term return $ ProductCal a b @@ -160,10 +160,16 @@ expr :: P.Parser CalExpr expr = P.try addOperator P.<|> term -- <* P.eof namedExpr :: P.Parser NamedCalExpr -namedExpr = do - name <- P.optionMaybe $ - P.between (parseCharInSpace '{') (parseCharInSpace '}') (P.many1 $ P.noneOf "}") - NamedCalExpr name <$> expr +namedExpr = P.try record P.<|> (NamedCalExpr Nothing <$> expr) + where + record = parseRecordType "calExpr" $ P.try long P.<|> short + long = do + name <- parseArgument "name" parseAnyString + ex <- parseArgument "expr" expr + return (NamedCalExpr (Just name) ex) + short = do + ex <- parseArgument "expr" expr + return (NamedCalExpr Nothing ex) readNamedCalExprs :: String -> Either String [NamedCalExpr] readNamedCalExprs s = From 316eb41f8a1bd881e8853ba872fc8437ffb98deb Mon Sep 17 00:00:00 2001 From: Clemens Schmid Date: Sat, 25 Nov 2023 17:14:32 +0100 Subject: [PATCH 6/6] potential solution for the expression name issue --- src/Currycarbon/CLI/RunCalibrate.hs | 17 ++++++++++------- src/Currycarbon/Parsers.hs | 13 ++++++------- src/Currycarbon/SumCalibration.hs | 4 +--- src/Currycarbon/Types.hs | 2 +- 4 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Currycarbon/CLI/RunCalibrate.hs b/src/Currycarbon/CLI/RunCalibrate.hs index b5961f1..80ecb2e 100644 --- a/src/Currycarbon/CLI/RunCalibrate.hs +++ b/src/Currycarbon/CLI/RunCalibrate.hs @@ -170,25 +170,28 @@ runCalibrate ( -- | Helper function to replace empty input names with a sequence of numbers, -- to get each input date an unique identifier replaceEmptyNames :: [NamedCalExpr] -> [NamedCalExpr] -replaceEmptyNames = zipWith (modifyExpr . show) ([1..] :: [Integer]) +replaceEmptyNames = zipWith (modifyNamedExpr . show) ([1..] :: [Integer]) where - modifyExpr :: String -> NamedCalExpr -> NamedCalExpr - modifyExpr i nexpr = nexpr { _expr = replaceName i (_expr nexpr) } + modifyNamedExpr :: String -> NamedCalExpr -> NamedCalExpr + modifyNamedExpr i nexpr = + if _exprID nexpr == "" + then nexpr { _exprID = i, _expr = replaceName i (_expr nexpr) } + else nexpr { _expr = replaceName i (_expr nexpr) } replaceName :: String -> CalExpr -> CalExpr replaceName i (UnCalDate (UncalC14 name x y)) = - if name == "unknownSampleName" + if name == "" then UnCalDate $ UncalC14 i x y else UnCalDate $ UncalC14 name x y replaceName i (WindowBP (TimeWindowBP name start stop)) = - if name == "unknownSampleName" + if name == "" then WindowBP $ TimeWindowBP i start stop else WindowBP $ TimeWindowBP name start stop replaceName i (WindowBCAD (TimeWindowBCAD name start stop)) = - if name == "unknownSampleName" + if name == "" then WindowBCAD $ TimeWindowBCAD i start stop else WindowBCAD $ TimeWindowBCAD name start stop replaceName i (CalDate (CalPDF name x y)) = - if name == "unknownSampleName" + if name == "" then CalDate $ CalPDF i x y else CalDate $ CalPDF name x y replaceName i (SumCal a b) = SumCal (replaceName (i ++ "s") a) (replaceName (i ++ "S") b) diff --git a/src/Currycarbon/Parsers.hs b/src/Currycarbon/Parsers.hs index beda8f8..bdf7f88 100644 --- a/src/Currycarbon/Parsers.hs +++ b/src/Currycarbon/Parsers.hs @@ -85,9 +85,8 @@ renderCalDatePretty ascii (calExpr, calPDF, calC14) = renderNamedCalExpr :: NamedCalExpr -> String renderNamedCalExpr (NamedCalExpr exprID calExpr) = renderExprID exprID ++ " " ++ renderCalExpr calExpr -renderExprID :: Maybe String -> String -renderExprID Nothing = "" -renderExprID (Just s) = "{" ++ s ++ "}" +renderExprID :: String -> String +renderExprID s = "[" ++ s ++ "]" renderCalExpr :: CalExpr -> String renderCalExpr (UnCalDate a) = renderUncalC14 a @@ -160,16 +159,16 @@ expr :: P.Parser CalExpr expr = P.try addOperator P.<|> term -- <* P.eof namedExpr :: P.Parser NamedCalExpr -namedExpr = P.try record P.<|> (NamedCalExpr Nothing <$> expr) +namedExpr = P.try record P.<|> (NamedCalExpr "" <$> expr) where record = parseRecordType "calExpr" $ P.try long P.<|> short long = do name <- parseArgument "name" parseAnyString ex <- parseArgument "expr" expr - return (NamedCalExpr (Just name) ex) + return (NamedCalExpr name ex) short = do ex <- parseArgument "expr" expr - return (NamedCalExpr Nothing ex) + return (NamedCalExpr "" ex) readNamedCalExprs :: String -> Either String [NamedCalExpr] readNamedCalExprs s = @@ -243,7 +242,7 @@ parseUncalC14 = parseRecordType "uncalC14" $ P.try long P.<|> short short = do age <- parseArgument "age" parseWord sigma <- parseArgument "sigma" parseWord - return (UncalC14 "unknownSampleName" age sigma) + return (UncalC14 "" age sigma) -- CalC14 -- | Write 'CalC14's to the file system. The output file is a long .csv file with the following structure: diff --git a/src/Currycarbon/SumCalibration.hs b/src/Currycarbon/SumCalibration.hs index c05d4a8..1b29fd8 100644 --- a/src/Currycarbon/SumCalibration.hs +++ b/src/Currycarbon/SumCalibration.hs @@ -16,9 +16,7 @@ evalNamedCalExpr :: CalibrateDatesConf -> CalCurveBP -> NamedCalExpr -> Either C evalNamedCalExpr conf curve (NamedCalExpr exprID expr) = case evalCalExpr conf curve expr of Left err -> Left err - Right calPDF -> case exprID of - Nothing -> Right calPDF - Just x -> Right $ calPDF { _calPDFid = x } + Right calPDF -> Right calPDF { _calPDFid = exprID } -- | Evaluate a dating expression by calibrating the individual dates and forming the respective -- sums and products of post-calibration density distributions diff --git a/src/Currycarbon/Types.hs b/src/Currycarbon/Types.hs index bed54ef..040c0c5 100644 --- a/src/Currycarbon/Types.hs +++ b/src/Currycarbon/Types.hs @@ -113,7 +113,7 @@ data CalPDF = CalPDF { -- | A data type for named calibration expressions data NamedCalExpr = NamedCalExpr { -- | Expression identifier - _exprID :: Maybe String + _exprID :: String -- | Expression , _expr :: CalExpr }