better data types

This commit is contained in:
Joey Hess 2014-02-17 00:38:33 -04:00
parent e806152f77
commit 103dab702b
2 changed files with 33 additions and 24 deletions

View file

@ -46,10 +46,10 @@ data ViewChange = Unchanged | Narrowing | Widening
-} -}
refineView :: View -> MetaField -> String -> (View, ViewChange) refineView :: View -> MetaField -> String -> (View, ViewChange)
refineView view field wanted refineView view field wanted
| field `elem` (map fst view) = | field `elem` (map viewField view) =
let (view', viewchanges) = runWriter $ mapM updatefield view let (view', viewchanges) = runWriter $ mapM updatefield view
in (view', maximum viewchanges) in (view', maximum viewchanges)
| otherwise = ((field, viewfilter) : view, Narrowing) | otherwise = (ViewComponent field viewfilter : view, Narrowing)
where where
viewfilter viewfilter
| any (`elem` wanted) "*?" = | any (`elem` wanted) "*?" =
@ -61,12 +61,12 @@ refineView view field wanted
FilterGlob (Glob wanted) FilterGlob (Glob wanted)
#endif #endif
| otherwise = FilterValues $ S.singleton $ toMetaValue wanted | otherwise = FilterValues $ S.singleton $ toMetaValue wanted
updatefield :: (MetaField, ViewFilter) -> Writer [ViewChange] (MetaField, ViewFilter) updatefield :: ViewComponent -> Writer [ViewChange] ViewComponent
updatefield v@(f, vf) updatefield v
| f == field = do | viewField v == field = do
let (newvf, viewchange) = combineViewFilter vf viewfilter let (newvf, viewchange) = combineViewFilter (viewFilter v) viewfilter
tell [viewchange] tell [viewchange]
return (f, newvf) return $ v { viewFilter = newvf }
| otherwise = return v | otherwise = return v
{- Combine old and new ViewFilters, yielding a results that matches {- Combine old and new ViewFilters, yielding a results that matches
@ -89,7 +89,7 @@ combineViewFilter old@(FilterValues olds) (FilterValues news)
| otherwise = (combined, Widening) | otherwise = (combined, Widening)
where where
combined = FilterValues (S.union olds news) combined = FilterValues (S.union olds news)
combineViewFilter (FilterValues old) newglob@(FilterGlob _) = combineViewFilter (FilterValues _) newglob@(FilterGlob _) =
(newglob, Widening) (newglob, Widening)
combineViewFilter (FilterGlob oldglob) new@(FilterValues s) combineViewFilter (FilterGlob oldglob) new@(FilterValues s)
| all (matchGlob oldglob . fromMetaValue) (S.toList s) = (new, Narrowing) | all (matchGlob oldglob . fromMetaValue) (S.toList s) = (new, Narrowing)
@ -113,14 +113,14 @@ multiValue (FilterGlob _) = True
- through 5+ levels of subdirectories to find anything? - through 5+ levels of subdirectories to find anything?
-} -}
viewTooLarge :: View -> Bool viewTooLarge :: View -> Bool
viewTooLarge view = length (filter (multiValue . snd) view) > 5 viewTooLarge view = length (filter (multiValue . viewFilter) view) > 5
{- Checks if metadata matches a filter, and if so returns the value, {- Checks if metadata matches a filter, and if so returns the value,
- or values that match. -} - or values that match. -}
matchFilter :: MetaData -> MetaField -> ViewFilter -> Maybe [MetaValue] matchFilter :: MetaData -> ViewComponent -> Maybe [MetaValue]
matchFilter metadata metafield (FilterValues s) = nonEmptyList $ matchFilter metadata (ViewComponent metafield (FilterValues s)) = nonEmptyList $
S.intersection s (currentMetaDataValues metafield metadata) S.intersection s (currentMetaDataValues metafield metadata)
matchFilter metadata metafield (FilterGlob glob) = nonEmptyList $ matchFilter metadata (ViewComponent metafield (FilterGlob glob)) = nonEmptyList $
S.filter (matchGlob glob . fromMetaValue) (currentMetaDataValues metafield metadata) S.filter (matchGlob glob . fromMetaValue) (currentMetaDataValues metafield metadata)
nonEmptyList :: S.Set a -> Maybe [a] nonEmptyList :: S.Set a -> Maybe [a]
@ -170,11 +170,11 @@ fileViews view mkfileview file metadata
map (map toViewPath) (visible matches) map (map toViewPath) (visible matches)
where where
matches :: [Maybe [MetaValue]] matches :: [Maybe [MetaValue]]
matches = map (uncurry $ matchFilter metadata) view matches = map (matchFilter metadata) view
visible :: [Maybe [MetaValue]] -> [[MetaValue]] visible :: [Maybe [MetaValue]] -> [[MetaValue]]
visible = map (fromJust . snd) . visible = map (fromJust . snd) .
filter (multiValue . fst) . filter (multiValue . fst) .
zip (map snd view) zip (map viewFilter view)
toViewPath :: MetaValue -> FilePath toViewPath :: MetaValue -> FilePath
toViewPath = concatMap escapeslash . fromMetaValue toViewPath = concatMap escapeslash . fromMetaValue
@ -218,8 +218,8 @@ pathProduct (l:ls) = foldl combinel l ls
fromView :: View -> FileView -> MetaData fromView :: View -> FileView -> MetaData
fromView view f = foldr (uncurry updateMetaData) newMetaData (zip fields values) fromView view f = foldr (uncurry updateMetaData) newMetaData (zip fields values)
where where
visible = filter (multiValue . snd) view visible = filter (multiValue . viewFilter) view
fields = map fst visible fields = map viewField visible
paths = splitDirectories $ dropFileName f paths = splitDirectories $ dropFileName f
values = map fromViewPath paths values = map fromViewPath paths
@ -231,9 +231,9 @@ prop_view_roundtrips :: FilePath -> MetaData -> Bool
prop_view_roundtrips f metadata = null f || viewTooLarge view || prop_view_roundtrips f metadata = null f || viewTooLarge view ||
all hasfields (fileViews view fileViewFromReference f metadata) all hasfields (fileViews view fileViewFromReference f metadata)
where where
view = map (\(mf, mv) -> (mf, FilterValues $ S.filter (not . null . fromMetaValue) mv)) view = map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv))
(fromMetaData metadata) (fromMetaData metadata)
visiblefields = sort (map fst $ filter (multiValue . snd) view) visiblefields = sort (map viewField $ filter (multiValue . viewFilter) view)
hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields
{- Generates a git branch name for a View. {- Generates a git branch name for a View.
@ -246,11 +246,11 @@ branchView view
| null name = Git.Ref "refs/views" | null name = Git.Ref "refs/views"
| otherwise = Git.Ref $ "refs/views/" ++ name | otherwise = Git.Ref $ "refs/views/" ++ name
where where
name = intercalate "/" $ map branchbit view name = intercalate "/" $ map branchcomp view
branchbit b@(_metafield, viewfilter) branchcomp c
| multiValue viewfilter = branchbit' b | multiValue (viewFilter c) = branchcomp' c
| otherwise = "(" ++ branchbit' b ++ ")" | otherwise = "(" ++ branchcomp' c ++ ")"
branchbit' (metafield, viewfilter) branchcomp' (ViewComponent metafield viewfilter)
| metafield == tagMetaField = branchvals viewfilter | metafield == tagMetaField = branchvals viewfilter
| otherwise = concat | otherwise = concat
[ forcelegal (fromMetaField metafield) [ forcelegal (fromMetaField metafield)

View file

@ -21,7 +21,16 @@ import Text.Regex.TDFA
#endif #endif
{- A view is a list of fields with filters on their allowed values. -} {- A view is a list of fields with filters on their allowed values. -}
type View = [(MetaField, ViewFilter)] type View = [ViewComponent]
data ViewComponent = ViewComponent
{ viewField :: MetaField
, viewFilter :: ViewFilter
}
deriving (Show, Eq)
instance Arbitrary ViewComponent where
arbitrary = ViewComponent <$> arbitrary <*> arbitrary
{- Only files with metadata matching the view are displayed. -} {- Only files with metadata matching the view are displayed. -}
type FileView = FilePath type FileView = FilePath