refactor: minor csv cleanups

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

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

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 }
+                  -> \x -> x { Csv.decDelimiter = nextChar }
-              _other -> guessDecodeOptions $ LBS.take firstDQuote testBuffer <> unused
+              _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
       ]
 

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 ()

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
+  toPathPiece = toPathPiece . (fromRational :: Rational -> Deci) . review numberGrade
-  fromPathPiece = finiteFromPathPiece
+  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

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