module Sindre.Widgets ( mkHorizontally
, mkVertically
, changeField
, changeField_
, changingField
, 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.Map as M
import qualified Data.Text as T
data Oriented = Oriented {
mergeSpace :: [SpaceNeed] -> SpaceNeed
, splitSpace :: Rectangle -> [SpaceNeed] -> [Rectangle]
, children :: [WidgetRef]
}
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))
M.empty [] (const $ return ()) composeI drawI
where merge rects = ( f (sumPrim, sumSec) $ map fst rects
, f (sumSec, sumPrim) $ map snd rects )
split r = f (splitVert, splitHoriz) r . map f
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)
mkHorizontally :: MonadBackend m => Constructor m
mkHorizontally = layouting fst
mkVertically :: MonadBackend m => Constructor m
mkVertically = layouting snd
changeField :: FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im v
changeField (ReadWriteField _ getter setter) m = do
v' <- m =<< getter
setter v'
return v'
changeField (ReadOnlyField _ _) _ = fail "Field is read-only"
changeField_ :: FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im ()
changeField_ f m = changeField f m >> return ()
changingField :: (MonadBackend im, Mold v) =>
FieldDesc s im v -> ObjectM s im a -> ObjectM s im a
changingField f m = do
v <- unmold <$> getField f
a <- m
v' <- unmold <$> getField f
changed (fieldName f) v v'
return a
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