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/ParserHelpers.hs b/src/Currycarbon/ParserHelpers.hs index 9e3af13..b624bfc 100644 --- a/src/Currycarbon/ParserHelpers.hs +++ b/src/Currycarbon/ParserHelpers.hs @@ -20,26 +20,37 @@ 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) -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 = - P.try parseNamedArgument P.<|> parseUnnamedArgument - where - parseNamedArgument = do - (_,b) <- parseKeyValuePair (P.string argumentName) parseValue - return b - parseUnnamedArgument = parseValue +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 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 @@ -75,7 +86,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 +126,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 58594c2..bdf7f88 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) @@ -13,7 +12,6 @@ import qualified Data.Vector as V import qualified Data.Vector.Unboxed as VU import qualified Text.Parsec as P import qualified Text.Parsec.String as P -import qualified Text.Parsec.Perm as P -- * Parsing, rendering and writing functions -- @@ -87,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 @@ -101,66 +98,77 @@ 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 parseTimeWindowBP :: P.Parser TimeWindowBP -parseTimeWindowBP = do - parseRecordType "rangeBP" $ do - res@(TimeWindowBP _ start stop) <- P.permute $ - TimeWindowBP - P.<$$> parseArgumentComma "name" parseAnyString - P.<||> parseArgumentComma "start" parseWord - P.<||> parseArgumentComma "stop" parseWord - --name <- parseArgumentComma "name" parseAnyString - --start <- parseArgumentComma "start" parseWord - --stop <- parseArgumentComma "stop" parseWord - if start >= stop - then return res - 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 - name <- P.many (P.noneOf ",") - _ <- parseCharInSpace ',' - start <- parseInteger - _ <- P.spaces *> P.string "-+-" <* P.spaces - stop <- parseInteger +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" -- https://gist.github.com/abhin4v/017a36477204a1d57745 -add :: P.Parser CalExpr -add = SumCal <$> term <*> (parseCharInSpace '+' *> expr) +addFun :: P.Parser CalExpr +addFun = parseRecordType "sum" $ 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 "product" $ do + a <- parseArgument "a" factor + b <- parseArgument "b" term + return $ ProductCal a b -mul :: P.Parser CalExpr -mul = ProductCal <$> factor <*> (parseCharInSpace '*' *> term) +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 - name <- P.optionMaybe $ - P.between (parseCharInSpace '{') (parseCharInSpace '}') (P.many1 $ P.noneOf "}") - NamedCalExpr name <$> 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 name ex) + short = do + ex <- parseArgument "expr" expr + return (NamedCalExpr "" ex) readNamedCalExprs :: String -> Either String [NamedCalExpr] readNamedCalExprs s = @@ -224,21 +232,17 @@ readUncalC14 s = uncalC14SepBySemicolon = P.sepBy parseUncalC14 (P.char ';' <* P.spaces) <* P.eof parseUncalC14 :: P.Parser UncalC14 -parseUncalC14 = do - P.try long P.<|> short +parseUncalC14 = 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 "" age sigma) -- CalC14 -- | Write 'CalC14's to the file system. The output file is a long .csv file with the following structure: @@ -305,7 +309,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 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 }