module Sindre.Widgets ( mkHorizontally
, mkVertically
, changeFields
, Match(..)
, match
, filterMatches
, sortMatches
)
where
import Sindre.Sindre
import Sindre.Compiler
import Sindre.Runtime
import Control.Monad.Error
import Control.Monad.State
import Control.Applicative
import Data.List
import Data.Maybe
import qualified Data.Text as T
data Oriented = Oriented {
mergeSpace :: [SpaceNeed] -> SpaceNeed
, splitSpace :: Rectangle -> [SpaceNeed] -> [Rectangle]
, children :: [WidgetRef]
}
instance MonadBackend m => Object m Oriented where
instance MonadBackend m => Widget m Oriented where
composeI = do
chlds <- gets children
gets mergeSpace <*> mapM compose chlds
drawI r = do
chlds <- gets children
rects <- gets splitSpace <*> pure r <*> mapM compose chlds
concat <$> zipWithM draw (reverse chlds) (Just <$> reverse rects)
sumPrim :: [DimNeed] -> DimNeed
sumPrim [] = Min 0
sumPrim (d:ds) = foldl f d ds
where f (Min x) (Min y) = Min (x+y)
f (Min x) (Max y) = Max (x+y)
f (Min x) (Exact y) = Min (x+y)
f (Max x) (Max y) = Max (x+y)
f (Max x) (Exact y) = Max (x+y)
f (Exact x) (Exact y) = Exact (x+y)
f _ Unlimited = Unlimited
f x y = f y x
sumSec :: [DimNeed] -> DimNeed
sumSec [] = Min 0
sumSec (d:ds) = foldl f d ds
where f (Min x) (Min y) = Min $ max x y
f (Min x) (Max y) | x < y = Max y
f (Min x) (Max _) = Max x
f (Min _) (Exact y) = Exact y
f (Max x) (Max y) = Max $ max x y
f (Max _) (Exact y) = Exact y
f (Max x) Unlimited = Max x
f (Exact x) (Exact y) = Exact $ max x y
f (Exact x) Unlimited = Exact x
f _ Unlimited = Unlimited
f x y = f y x
layouting :: MonadBackend m => (forall a. ((a, a) -> a)) -> Constructor m
layouting f _ cs = return $ NewWidget $ Oriented merge split (map snd cs)
where merge rects = ( f (sumPrim, sumSec) $ map fst rects
, f (sumSec, sumPrim) $ map snd rects )
split r = f (splitVert, splitHoriz) r . map f
mkHorizontally :: MonadBackend m => Constructor m
mkHorizontally = layouting fst
mkVertically :: MonadBackend m => Constructor m
mkVertically = layouting snd
changeFields :: MonadBackend im => [(Identifier, a -> Value)]
-> (a -> ObjectM a im a) -> ObjectM a im ()
changeFields fs m = do
s <- get
s' <- m s
put s' >> mapM_ (\(k, f) -> changed k (f s) (f s')) fs
data Match = ExactMatch
| PrefixMatch
| InfixMatch
deriving (Eq, Ord, Show)
match :: T.Text -> T.Text -> Maybe Match
match pat s
| pat == s = Just ExactMatch
| otherwise =
case T.words pat of
[] -> Just PrefixMatch
pat'@(x:_) | all look pat' -> if x `T.isPrefixOf` s
then Just PrefixMatch
else Just InfixMatch
| otherwise -> Nothing
where look tok = tok `T.isInfixOf` s
filterMatches :: (a -> T.Text) -> T.Text -> [a] -> [a]
filterMatches f pat = filter (isJust . match pat . f)
sortMatches :: (a -> T.Text) -> T.Text -> [a] -> [a]
sortMatches f t ts = map snd $ exacts++prefixes++infixes
where attach y = do m <- match t $ f y
return (m, y)
matches = mapMaybe attach ts
(exacts, nonexacts) = partition ((==ExactMatch) . fst) matches
(prefixes, infixes) =
partition ((==PrefixMatch) . fst) nonexacts