Commit 6c10bbbc authored by Mike Ledger's avatar Mike Ledger

support saving labels into separate files

parent 693dafe7
......@@ -2,16 +2,18 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import Control.Lens (failing, re, to, (^?), _Left,
_Right)
import Control.Lens (failing, iforM_, re, to,
(^?), _Left, _Right)
import Control.Monad (when)
import Control.Monad.Trans.Resource (MonadResource, runResourceT)
import Control.Monad.Trans.State.Strict (State, evalState, get, modify')
import Control.Monad.Trans.State.Strict (State, get, modify',
runState)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Streaming as B
import qualified Data.ByteString.Streaming.Char8 as Q (lines)
......@@ -47,8 +49,12 @@ data MapExpr k a
= Union (MapExpr k a) (MapExpr k a)
| Difference (MapExpr k a) (MapExpr k a)
| Intersection (MapExpr k a) (MapExpr k a)
| LongUnion (MapExpr k a) (MapExpr k a)
| LongIntersection (MapExpr k a) (MapExpr k a)
| UnionWithAll (MapExpr k a) (MapExpr k a)
| UnionWithChooseLeft (MapExpr k a) (MapExpr k a)
| UnionWithChooseRight (MapExpr k a) (MapExpr k a)
| IntersectionWithAll (MapExpr k a) (MapExpr k a)
| IntersectionWithChooseLeft (MapExpr k a) (MapExpr k a)
| IntersectionWithChooseRight (MapExpr k a) (MapExpr k a)
| DocNum {-# UNPACK #-} !Int
| Labelled {-# UNPACK #-} !Text (MapExpr k a)
| Label !Text
......@@ -56,24 +62,38 @@ data MapExpr k a
| Error
deriving (Eq, Show, Read, Ord, Generic)
chooseR :: [a] -> [a] -> [a]
chooseR _ a@(_:_) = a
chooseR a _ = a
chooseL :: [a] -> [a] -> [a]
chooseL a@(_:_) _ = a
chooseL _ a = a
parseMapExpr :: Parser (MapExpr k a)
parseMapExpr =
buildExpressionParser
[ [ binary "*." LongIntersection AssocLeft
[ [ binary "|*|" IntersectionWithAll AssocLeft
, binary "|*" IntersectionWithChooseLeft AssocLeft
, binary "*|" IntersectionWithChooseRight AssocLeft
, binary "*" Intersection AssocLeft
]
, [ binary "+." LongUnion AssocRight
, [ binary "|+|" UnionWithAll AssocRight
, binary "|+" UnionWithChooseLeft AssocRight
, binary "+|" UnionWithChooseRight AssocRight
, binary "+" Union AssocRight
, binary "-" Difference AssocLeft
]
, [ binary ":" mkLabel AssocRight ]
]
term
where
mkLabel (Label t) = Labelled t
mkLabel _ = const Error
term =
(do lit <- P.token P.stringLiteral
mterm <- P.optional (P.symbolic ':' *> term)
return (maybe (Label lit) (Labelled lit) mterm))
<|> P.token (DocNum . fromInteger <$> (P.char '$' *> P.decimal))
P.token (DocNum . fromInteger <$> P.decimal <|>
Label <$> P.stringLiteral)
<|> P.parens parseMapExpr
binary name fun =
......@@ -120,7 +140,8 @@ data Options k a = Options
\4. Union combining all columns with the +. operator;\n\
\5 .Intersection combining all columns with the *. operator\n\
\6. Labels for expressions with the syntax '\"LABEL\": EXPR'.")
, verbose :: Maybe Bool
, saveLabels :: Maybe Bool
, verbose :: Maybe Bool
} deriving (Show, Generic)
instance (Typeable k, Typeable a) => ParseRecord (Options k a) where
......@@ -167,12 +188,26 @@ output opts = case unHelpful (outfile opts) of
Just out -> B.writeFile out
Nothing -> B.stdout
interpret :: forall a k. (Monoid a, Ord k, Ord a) => MapExpr k a -> V.Vector (Map.Map k a) -> Map.Map k a
interpret me0 v = case evalState (go me0) Map.empty of
Result r -> r
_ -> Map.empty
interpret
:: forall a k e. (Monoid a, Ord k, Ord a, a ~ [e])
=> MapExpr k a
-> V.Vector (Map.Map k a)
-> (Map.Map Text (Map.Map k a), Map.Map k a)
interpret me0 v = case runState (go me0) Map.empty of
(Result r, s) -> (getLabels s, r)
(_, s) -> (getLabels s, Map.empty)
where
takeLabel (Label l) = l
takeLabel _ = error "takeLabel"
takeResult (Result a) = a
takeResult _ = Map.empty
getLabels = Map.map takeResult . Map.mapKeys takeLabel . Map.filterWithKey (\k _ -> case k of
Label _ -> True
_ -> False)
withResult2 f (Result a) (Result b) = Result (f a b)
withResult2 _ _ _ = Error
......@@ -185,28 +220,35 @@ interpret me0 v = case evalState (go me0) Map.empty of
case Map.lookup me cache of
Just x -> return x
Nothing -> case me of
Labelled k a -> do
Labelled k a -> do
a' <- go a
modify' (Map.insert (Label k) a')
return a'
Label k -> return (Label k)
DocNum i -> ins (Result (v V.! (i - 1)))
Union a b -> ins =<< withResult2 Map.union <$> go a <*> go b
Difference a b -> ins =<< withResult2 Map.difference <$> go a <*> go b
Intersection a b -> ins =<< withResult2 Map.intersection <$> go a <*> go b
LongUnion a b -> ins =<< withResult2 (Map.unionWith mappend) <$> go a <*> go b
LongIntersection a b -> ins =<< withResult2 (Map.intersectionWith mappend) <$> go a <*> go b
_ -> return me
Label k -> return (Label k)
DocNum i -> ins (Result (v V.! (i - 1)))
Union a b -> ins =<< withResult2 Map.union <$> go a <*> go b
Difference a b -> ins =<< withResult2 Map.difference <$> go a <*> go b
Intersection a b -> ins =<< withResult2 Map.intersection <$> go a <*> go b
UnionWithAll a b -> ins =<< withResult2 (Map.unionWith mappend) <$> go a <*> go b
UnionWithChooseLeft a b -> ins =<< withResult2 (Map.unionWith chooseL) <$> go a <*> go b
UnionWithChooseRight a b -> ins =<< withResult2 (Map.unionWith chooseR) <$> go a <*> go b
IntersectionWithAll a b -> ins =<< withResult2 (Map.intersectionWith mappend) <$> go a <*> go b
IntersectionWithChooseLeft a b -> ins =<< withResult2 (Map.intersectionWith chooseL) <$> go a <*> go b
IntersectionWithChooseRight a b -> ins =<< withResult2 (Map.intersectionWith chooseR) <$> go a <*> go b
_ -> return me
-- | select the combining algorithm
combine :: (Monoid a, Ord k, Ord a) => Options k a -> [Map.Map k a] -> Map.Map k a
combine opts =
combine :: (Monoid a, Ord k, Ord a, a ~ [e])
=> Options k a
-> [Map.Map k a]
-> (Map.Map Text (Map.Map k a), Map.Map k a)
combine opts ms =
case unHelpful (expr opts) of
Just expr -> interpret expr . V.fromList
Nothing -> case unHelpful (op opts) of
Just OpIntersection -> foldr1 Map.intersection
Just OpDifference -> foldr1 Map.difference
_union -> Map.unions
Just expr -> interpret expr (V.fromList ms)
Nothing -> (Map.empty, case unHelpful (op opts) of
Just OpIntersection -> foldr1 Map.intersection ms
Just OpDifference -> foldr1 Map.difference ms
_union -> Map.unions ms)
main :: IO ()
main = do
......@@ -220,11 +262,12 @@ main = do
. S.partitionEithers
. S.map (either (const (Left ())) toRow)
. decodeFile opts)
(unHelpful infiles) >>=
(unHelpful infiles) >>= \o ->
-- write output
output opts
. Csv.encode
-- TODO: add header
. mapM_ (S.yield . uncurry (:))
. Map.toList
. combine opts
let (labelled, r) = combine opts o
writeCsv opts' = output opts' . Csv.encode . mapM_ (S.yield . uncurry (:)) . Map.toList
in do
writeCsv opts r
when (saveLabels == Just True) $ iforM_ labelled $ \name -> writeCsv opts
{ outfile = Helpful (Just (T.unpack name ++ ".csv"))
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment