diff --git a/src/Data/Fixed/Instances.hs b/src/Data/Fixed/Instances.hs index 53696e9e6..7593400e3 100644 --- a/src/Data/Fixed/Instances.hs +++ b/src/Data/Fixed/Instances.hs @@ -10,10 +10,12 @@ import Data.Fixed import Text.Blaze (ToMarkup(..)) import qualified Data.Csv as Csv +import Web.PathPieces import Data.Proxy (Proxy(..)) import Data.Scientific +import Data.Scientific.Instances () instance HasResolution a => ToMarkup (Fixed a) where @@ -24,3 +26,7 @@ instance HasResolution a => Csv.ToField (Fixed a) where toField = Csv.toField . (realToFrac :: Fixed a -> Scientific) instance HasResolution a => Csv.FromField (Fixed a) where parseField = fmap (MkFixed . (round :: Scientific -> Integer) . (* fromInteger (resolution $ Proxy @a))) . Csv.parseField + +instance HasResolution a => PathPiece (Fixed a) where + toPathPiece = toPathPiece . (realToFrac :: Fixed a -> Scientific) + fromPathPiece = fmap (MkFixed . (round :: Scientific -> Integer) . (* fromInteger (resolution $ Proxy @a))) . fromPathPiece diff --git a/src/Data/Scientific/Instances.hs b/src/Data/Scientific/Instances.hs new file mode 100644 index 000000000..85c46f844 --- /dev/null +++ b/src/Data/Scientific/Instances.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Scientific.Instances + ( + ) where + +import ClassyPrelude +import Data.Scientific + +import Web.PathPieces + + +instance PathPiece Scientific where + toPathPiece = pack . formatScientific Fixed Nothing + fromPathPiece = readFromPathPiece diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index e0c2e21ae..03a9d4d77 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -14,11 +14,14 @@ module Handler.Utils.Csv , toCsvRendered ) where -import Import hiding (Header) +import Import hiding (Header, mapM_) import Data.Csv import Data.Csv.Conduit +import Data.Function ((&)) +import Control.Monad (mapM_) + -- import qualified Data.Csv.Util as Csv import qualified Data.Csv.Parser as Csv @@ -52,7 +55,8 @@ decodeCsv = transPipe throwExceptT $ do testBuffer <- accumTestBuffer LBS.empty mapM_ leftover $ LBS.toChunks testBuffer - let decodeOptions = guessDecodeOptions testBuffer + let decodeOptions = defaultDecodeOptions + & guessDelimiter testBuffer $logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|] fromNamedCsv decodeOptions @@ -66,27 +70,27 @@ decodeCsv = transPipe throwExceptT $ do Nothing -> return acc Just frag' -> accumTestBuffer (acc <> LBS.fromStrict frag') - guessDecodeOptions testBuffer + guessDelimiter testBuffer | Just firstDQuote <- doubleQuote `LBS.elemIndex` testBuffer = if | firstDQuote /= 0 - -> Csv.DecodeOptions $ testBuffer `LBS.index` pred firstDQuote + -> \x -> x { Csv.decDelimiter = testBuffer `LBS.index` pred firstDQuote } | A.Done unused _ <- A.parse quotedField testBuffer -> case A.parse endOfLine unused of - A.Fail _ _ _ + A.Fail{} | Just (nextChar, _) <- LBS.uncons unused - -> defaultDecodeOptions { Csv.decDelimiter = nextChar } - _other -> guessDecodeOptions $ LBS.take firstDQuote testBuffer <> unused + -> \x -> x { Csv.decDelimiter = nextChar } + _other -> guessDelimiter $ LBS.take firstDQuote testBuffer <> unused | otherwise - -> defaultDecodeOptions -- Parsing of something, which should be a quoted field, failed; bail now + -> id -- Parsing of something, which should be a quoted field, failed; bail now | A.Done _ ls <- A.parse (A.many1 $ A.manyTill A.anyWord8 endOfLine) testBuffer , (h:hs) <- filter (not . Map.null) $ map (fmap getSum . Map.unionsWith mappend . map (flip Map.singleton $ Sum 1)) ls , Just equals <- fromNullable $ Map.filterWithKey (\c n -> all ((== Just n) . Map.lookup c) hs) h , let maxH = maximum equals , [d] <- filter ((== Just maxH) . flip Map.lookup (toNullable equals)) . Map.keys $ toNullable equals - = defaultDecodeOptions { Csv.decDelimiter = d } + = \x -> x { Csv.decDelimiter = d } | otherwise - = defaultDecodeOptions + = id quotedField :: A.Parser () -- We don't care about the return value @@ -96,7 +100,7 @@ decodeCsv = transPipe throwExceptT $ do endOfLine :: A.Parser () endOfLine = asum [ void $ A.word8 newline - , mapM_ (void . A.word8) [cr, newline] + , mapM_ A.word8 [cr, newline] , void $ A.word8 cr ] diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index e530b0d0f..7ec441d58 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -88,6 +88,7 @@ import Data.Maybe.Instances as Import () import Data.CryptoID.Instances as Import () import Data.Sum.Instances as Import () import Data.Fixed.Instances as Import () +import Data.Scientific.Instances as Import () import Data.Set.Instances as Import () import Data.HashMap.Strict.Instances as Import () import Data.HashSet.Instances as Import () diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 29928f876..ef5a8f1f9 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -160,8 +160,8 @@ numberGrade = prism toNumberGrade fromNumberGrade n -> Left n instance PathPiece ExamGrade where - toPathPiece = tshow . (fromRational :: Rational -> Deci) . review numberGrade - fromPathPiece = finiteFromPathPiece + toPathPiece = toPathPiece . (fromRational :: Rational -> Deci) . review numberGrade + fromPathPiece = preview numberGrade . (toRational :: Deci -> Rational) <=< fromPathPiece pathPieceJSON ''ExamGrade pathPieceJSONKey ''ExamGrade @@ -169,7 +169,10 @@ pathPieceJSONKey ''ExamGrade instance Csv.ToField ExamGrade where toField = Csv.toField . toPathPiece instance Csv.FromField ExamGrade where - parseField x = (parse =<< Csv.parseField x) <|> (parse . Text.replace "," "." =<< Csv.parseField x) -- Ugh. + parseField x = asum + [ parse =<< Csv.parseField x + , parse . Text.replace "," "." =<< Csv.parseField x -- Ugh. + ] where parse = maybe (fail "Could not decode PathPiece") return . fromPathPiece instance PersistField ExamGrade where diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 3a08c8b2d..49faef34f 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -27,6 +27,11 @@ import qualified Net.IP as IP import Web.PathPieces +import qualified Data.Csv as Csv +import Data.Scientific + +import Utils.Lens + instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where arbitrary = arbitrary `suchThatMap` fromNullable @@ -296,8 +301,10 @@ spec = do [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @Value) [ persistFieldLaws ] + lawsCheckHspec (Proxy @Scientific) + [ pathPieceLaws ] lawsCheckHspec (Proxy @Points) - [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws, csvFieldLaws ] + [ eqLaws, ordLaws, showReadLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ] lawsCheckHspec (Proxy @NotificationTrigger) [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ] lawsCheckHspec (Proxy @NotificationSettings) @@ -341,7 +348,7 @@ spec = do \term -> termFromRational (termToRational term) == term describe "Pseudonym" $ do it "has sufficient vocabulary" $ - (length pseudonymWordlist ^ 2) `shouldBe` (succ $ fromIntegral (maxBound - minBound :: Pseudonym)) + (length pseudonymWordlist ^ 2) `shouldSatisfy` (> (fromIntegral (maxBound :: Pseudonym) - fromIntegral (minBound :: Pseudonym))) it "has compatible encoding/decoding to/from Text" . property $ \pseudonym -> preview _PseudonymText (review _PseudonymText pseudonym) == Just pseudonym it "encodes to Text injectively" . property $ @@ -350,6 +357,15 @@ spec = do it "encodes to PathPiece as expected" . example $ do toPathPiece (ExamPassed False) `shouldBe` pack "failed" toPathPiece (ExamPassed True) `shouldBe` pack "passed" + describe "ExamGrade" $ + it "decodes some examples from CSV" . example $ do + let parse = Csv.runParser . Csv.parseField + parse "5" `shouldBe` Right (ExamAttended Grade50) + parse "1,7" `shouldBe` Right (ExamAttended Grade17) + parse "1.7" `shouldBe` Right (ExamAttended Grade17) + parse "1.8" `shouldSatisfy` is _Left + parse "voided" `shouldBe` Right ExamVoided + parse "no-show" `shouldBe` Right ExamNoShow termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do