{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ImpredicativeTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Sindre.Widgets
-- License     :  MIT-style (see LICENSE)
--
-- Stability   :  provisional
-- Portability :  portable
--
-- Portable Sindre gadgets and helper functions that can be used by
-- any backend.
--
-----------------------------------------------------------------------------
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 {
      Oriented -> [SpaceNeed] -> SpaceNeed
mergeSpace :: [SpaceNeed] -> SpaceNeed
    , Oriented -> Rectangle -> [SpaceNeed] -> [Rectangle]
splitSpace :: Rectangle -> [SpaceNeed] -> [Rectangle]
    , Oriented -> [WidgetRef]
children   :: [WidgetRef]
  }

sumPrim :: [DimNeed] -> DimNeed
sumPrim :: [DimNeed] -> DimNeed
sumPrim []     = Integer -> DimNeed
Min Integer
0
sumPrim (DimNeed
d:[DimNeed]
ds) = (DimNeed -> DimNeed -> DimNeed) -> DimNeed -> [DimNeed] -> DimNeed
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DimNeed -> DimNeed -> DimNeed
f DimNeed
d [DimNeed]
ds
    where f :: DimNeed -> DimNeed -> DimNeed
f (Min Integer
x) (Min Integer
y) = Integer -> DimNeed
Min (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)
          f (Min Integer
x) (Max Integer
y) = Integer -> DimNeed
Max (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)
          f (Min Integer
x) (Exact Integer
y) = Integer -> DimNeed
Min (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)
          f (Max Integer
x) (Max Integer
y) = Integer -> DimNeed
Max (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)
          f (Max Integer
x) (Exact Integer
y) = Integer -> DimNeed
Max (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)
          f (Exact Integer
x) (Exact Integer
y) = Integer -> DimNeed
Exact (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
y)
          f DimNeed
_ DimNeed
Unlimited = DimNeed
Unlimited
          f DimNeed
x DimNeed
y = DimNeed -> DimNeed -> DimNeed
f DimNeed
y DimNeed
x

sumSec :: [DimNeed] -> DimNeed
sumSec :: [DimNeed] -> DimNeed
sumSec []     = Integer -> DimNeed
Min Integer
0
sumSec (DimNeed
d:[DimNeed]
ds) = (DimNeed -> DimNeed -> DimNeed) -> DimNeed -> [DimNeed] -> DimNeed
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DimNeed -> DimNeed -> DimNeed
f DimNeed
d [DimNeed]
ds
    where f :: DimNeed -> DimNeed -> DimNeed
f (Min Integer
x) (Min Integer
y) = Integer -> DimNeed
Min (Integer -> DimNeed) -> Integer -> DimNeed
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
x Integer
y
          f (Min Integer
x) (Max Integer
y) | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
y = Integer -> DimNeed
Max Integer
y
          f (Min Integer
x) (Max Integer
_)         = Integer -> DimNeed
Max Integer
x
          f (Min Integer
_) (Exact Integer
y)         = Integer -> DimNeed
Exact Integer
y
          f (Max Integer
x) (Max Integer
y) = Integer -> DimNeed
Max (Integer -> DimNeed) -> Integer -> DimNeed
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
x Integer
y
          f (Max Integer
_) (Exact Integer
y) = Integer -> DimNeed
Exact Integer
y
          f (Max Integer
x) DimNeed
Unlimited = Integer -> DimNeed
Max Integer
x
          f (Exact Integer
x) (Exact Integer
y) = Integer -> DimNeed
Exact (Integer -> DimNeed) -> Integer -> DimNeed
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
x Integer
y
          f (Exact Integer
x) DimNeed
Unlimited = Integer -> DimNeed
Exact Integer
x
          f DimNeed
_ DimNeed
Unlimited = DimNeed
Unlimited
          f DimNeed
x DimNeed
y = DimNeed -> DimNeed -> DimNeed
f DimNeed
y DimNeed
x

layouting :: MonadBackend m => (forall a. ((a, a) -> a)) -> Constructor m
layouting :: (forall a. (a, a) -> a) -> Constructor m
layouting forall a. (a, a) -> a
f WidgetRef
_ [(Maybe Value, WidgetRef)]
cs = NewWidget m -> ConstructorM m (NewWidget m)
forall (m :: * -> *) a. Monad m => a -> m a
return (NewWidget m -> ConstructorM m (NewWidget m))
-> NewWidget m -> ConstructorM m (NewWidget m)
forall a b. (a -> b) -> a -> b
$ Oriented
-> Map Identifier (Method Oriented m)
-> [Field Oriented m]
-> (Event -> ObjectM Oriented m ())
-> ObjectM Oriented m SpaceNeed
-> (Rectangle -> ObjectM Oriented m [Rectangle])
-> NewWidget m
forall s (im :: * -> *).
s
-> Map Identifier (Method s im)
-> [Field s im]
-> (Event -> ObjectM s im ())
-> ObjectM s im SpaceNeed
-> (Rectangle -> ObjectM s im [Rectangle])
-> NewWidget im
newWidget (([SpaceNeed] -> SpaceNeed)
-> (Rectangle -> [SpaceNeed] -> [Rectangle])
-> [WidgetRef]
-> Oriented
Oriented [SpaceNeed] -> SpaceNeed
merge Rectangle -> [SpaceNeed] -> [Rectangle]
split (((Maybe Value, WidgetRef) -> WidgetRef)
-> [(Maybe Value, WidgetRef)] -> [WidgetRef]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Value, WidgetRef) -> WidgetRef
forall a b. (a, b) -> b
snd [(Maybe Value, WidgetRef)]
cs))
                   Map Identifier (Method Oriented m)
forall k a. Map k a
M.empty [] (ObjectM Oriented m () -> Event -> ObjectM Oriented m ()
forall a b. a -> b -> a
const (ObjectM Oriented m () -> Event -> ObjectM Oriented m ())
-> ObjectM Oriented m () -> Event -> ObjectM Oriented m ()
forall a b. (a -> b) -> a -> b
$ () -> ObjectM Oriented m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ObjectM Oriented m SpaceNeed
composeI Rectangle -> ObjectM Oriented m [Rectangle]
forall (m :: (* -> *) -> * -> *) (im :: * -> *).
(MonadState Oriented (m im), MonadSindre im m) =>
Rectangle -> m im [Rectangle]
drawI
    where merge :: [SpaceNeed] -> SpaceNeed
merge [SpaceNeed]
rects = ( ([DimNeed] -> DimNeed, [DimNeed] -> DimNeed)
-> [DimNeed] -> DimNeed
forall a. (a, a) -> a
f ([DimNeed] -> DimNeed
sumPrim, [DimNeed] -> DimNeed
sumSec) ([DimNeed] -> DimNeed) -> [DimNeed] -> DimNeed
forall a b. (a -> b) -> a -> b
$ (SpaceNeed -> DimNeed) -> [SpaceNeed] -> [DimNeed]
forall a b. (a -> b) -> [a] -> [b]
map SpaceNeed -> DimNeed
forall a b. (a, b) -> a
fst [SpaceNeed]
rects
                        , ([DimNeed] -> DimNeed, [DimNeed] -> DimNeed)
-> [DimNeed] -> DimNeed
forall a. (a, a) -> a
f ([DimNeed] -> DimNeed
sumSec, [DimNeed] -> DimNeed
sumPrim) ([DimNeed] -> DimNeed) -> [DimNeed] -> DimNeed
forall a b. (a -> b) -> a -> b
$ (SpaceNeed -> DimNeed) -> [SpaceNeed] -> [DimNeed]
forall a b. (a -> b) -> [a] -> [b]
map SpaceNeed -> DimNeed
forall a b. (a, b) -> b
snd [SpaceNeed]
rects )
          split :: Rectangle -> [SpaceNeed] -> [Rectangle]
split Rectangle
r     = (Rectangle -> [DimNeed] -> [Rectangle],
 Rectangle -> [DimNeed] -> [Rectangle])
-> Rectangle -> [DimNeed] -> [Rectangle]
forall a. (a, a) -> a
f (Rectangle -> [DimNeed] -> [Rectangle]
splitVert, Rectangle -> [DimNeed] -> [Rectangle]
splitHoriz) Rectangle
r ([DimNeed] -> [Rectangle])
-> ([SpaceNeed] -> [DimNeed]) -> [SpaceNeed] -> [Rectangle]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpaceNeed -> DimNeed) -> [SpaceNeed] -> [DimNeed]
forall a b. (a -> b) -> [a] -> [b]
map SpaceNeed -> DimNeed
forall a. (a, a) -> a
f
          composeI :: ObjectM Oriented m SpaceNeed
composeI = do
            [WidgetRef]
chlds <- (Oriented -> [WidgetRef]) -> ObjectM Oriented m [WidgetRef]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Oriented -> [WidgetRef]
children
            (Oriented -> [SpaceNeed] -> SpaceNeed)
-> ObjectM Oriented m ([SpaceNeed] -> SpaceNeed)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Oriented -> [SpaceNeed] -> SpaceNeed
mergeSpace ObjectM Oriented m ([SpaceNeed] -> SpaceNeed)
-> ObjectM Oriented m [SpaceNeed] -> ObjectM Oriented m SpaceNeed
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (WidgetRef -> ObjectM Oriented m SpaceNeed)
-> [WidgetRef] -> ObjectM Oriented m [SpaceNeed]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM WidgetRef -> ObjectM Oriented m SpaceNeed
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
WidgetRef -> m im SpaceNeed
compose [WidgetRef]
chlds
          drawI :: Rectangle -> m im [Rectangle]
drawI Rectangle
r = do
            [WidgetRef]
chlds <- (Oriented -> [WidgetRef]) -> m im [WidgetRef]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Oriented -> [WidgetRef]
children
            [Rectangle]
rects <- (Oriented -> Rectangle -> [SpaceNeed] -> [Rectangle])
-> m im (Rectangle -> [SpaceNeed] -> [Rectangle])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Oriented -> Rectangle -> [SpaceNeed] -> [Rectangle]
splitSpace m im (Rectangle -> [SpaceNeed] -> [Rectangle])
-> m im Rectangle -> m im ([SpaceNeed] -> [Rectangle])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rectangle -> m im Rectangle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rectangle
r m im ([SpaceNeed] -> [Rectangle])
-> m im [SpaceNeed] -> m im [Rectangle]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (WidgetRef -> m im SpaceNeed) -> [WidgetRef] -> m im [SpaceNeed]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM WidgetRef -> m im SpaceNeed
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
WidgetRef -> m im SpaceNeed
compose [WidgetRef]
chlds
            [[Rectangle]] -> [Rectangle]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Rectangle]] -> [Rectangle])
-> m im [[Rectangle]] -> m im [Rectangle]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WidgetRef -> Maybe Rectangle -> m im [Rectangle])
-> [WidgetRef] -> [Maybe Rectangle] -> m im [[Rectangle]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM WidgetRef -> Maybe Rectangle -> m im [Rectangle]
forall (im :: * -> *) (m :: (* -> *) -> * -> *).
MonadSindre im m =>
WidgetRef -> Maybe Rectangle -> m im [Rectangle]
draw ([WidgetRef] -> [WidgetRef]
forall a. [a] -> [a]
reverse [WidgetRef]
chlds) (Rectangle -> Maybe Rectangle
forall a. a -> Maybe a
Just (Rectangle -> Maybe Rectangle) -> [Rectangle] -> [Maybe Rectangle]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Rectangle] -> [Rectangle]
forall a. [a] -> [a]
reverse [Rectangle]
rects)

-- | A widget that arranges its children in a horizontal row.
mkHorizontally :: MonadBackend m => Constructor m
mkHorizontally :: Constructor m
mkHorizontally = (forall a. (a, a) -> a) -> Constructor m
forall (m :: * -> *).
MonadBackend m =>
(forall a. (a, a) -> a) -> Constructor m
layouting forall a. (a, a) -> a
forall a b. (a, b) -> a
fst

-- | A widget that arranges its children in a vertical column.
mkVertically :: MonadBackend m => Constructor m
mkVertically :: Constructor m
mkVertically = (forall a. (a, a) -> a) -> Constructor m
forall (m :: * -> *).
MonadBackend m =>
(forall a. (a, a) -> a) -> Constructor m
layouting forall a. (a, a) -> a
forall a b. (a, b) -> b
snd

-- | @changeField field m@ applies @m@ to the current value of the
-- field @field@, updates @field@ with the value returned by @m@, and
-- returns the new value.
changeField :: MonadFail im => FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im v
changeField :: FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im v
changeField (ReadWriteField Identifier
_ ObjectM s im v
getter v -> ObjectM s im ()
setter) v -> ObjectM s im v
m = do
  v
v' <- v -> ObjectM s im v
m (v -> ObjectM s im v) -> ObjectM s im v -> ObjectM s im v
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ObjectM s im v
getter
  v -> ObjectM s im ()
setter v
v'
  v -> ObjectM s im v
forall (m :: * -> *) a. Monad m => a -> m a
return v
v'
changeField (ReadOnlyField Identifier
_ ObjectM s im v
_) v -> ObjectM s im v
_ = Identifier -> ObjectM s im v
forall (m :: * -> *) a. MonadFail m => Identifier -> m a
fail Identifier
"Field is read-only"

-- | Like 'changeField', but without a return value.
changeField_ :: MonadFail im => FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im ()
changeField_ :: FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im ()
changeField_ FieldDesc s im v
f v -> ObjectM s im v
m = ObjectM s im v -> ObjectM s im ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ObjectM s im v -> ObjectM s im ())
-> ObjectM s im v -> ObjectM s im ()
forall a b. (a -> b) -> a -> b
$ FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im v
forall (im :: * -> *) s v.
MonadFail im =>
FieldDesc s im v -> (v -> ObjectM s im v) -> ObjectM s im v
changeField FieldDesc s im v
f v -> ObjectM s im v
m

-- | @changingFields fields m@ evaluates @m@, then emits field change
-- events for those fields whose names are in @fields@ that changed
-- while evaluating @m@.
changingField :: (MonadBackend im, Mold v) =>
                 FieldDesc s im v -> ObjectM s im a -> ObjectM s im a
changingField :: FieldDesc s im v -> ObjectM s im a -> ObjectM s im a
changingField FieldDesc s im v
f ObjectM s im a
m = do
  Value
v <- v -> Value
forall a. Mold a => a -> Value
unmold (v -> Value) -> ObjectM s im v -> ObjectM s im Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDesc s im v -> ObjectM s im v
forall s (im :: * -> *) v. FieldDesc s im v -> ObjectM s im v
getField FieldDesc s im v
f
  a
a <- ObjectM s im a
m
  Value
v' <- v -> Value
forall a. Mold a => a -> Value
unmold (v -> Value) -> ObjectM s im v -> ObjectM s im Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDesc s im v -> ObjectM s im v
forall s (im :: * -> *) v. FieldDesc s im v -> ObjectM s im v
getField FieldDesc s im v
f
  Identifier -> Value -> Value -> ObjectM s im ()
forall (im :: * -> *) o.
MonadBackend im =>
Identifier -> Value -> Value -> ObjectM o im ()
changed (FieldDesc s im v -> Identifier
forall s (im :: * -> *) v. FieldDesc s im v -> Identifier
fieldName FieldDesc s im v
f) Value
v Value
v'
  a -> ObjectM s im a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | The result of using 'match' to apply a user-provided pattern to a
-- string.
data Match = ExactMatch
           | PrefixMatch
           | InfixMatch
             deriving (Match -> Match -> Bool
(Match -> Match -> Bool) -> (Match -> Match -> Bool) -> Eq Match
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Match -> Match -> Bool
$c/= :: Match -> Match -> Bool
== :: Match -> Match -> Bool
$c== :: Match -> Match -> Bool
Eq, Eq Match
Eq Match
-> (Match -> Match -> Ordering)
-> (Match -> Match -> Bool)
-> (Match -> Match -> Bool)
-> (Match -> Match -> Bool)
-> (Match -> Match -> Bool)
-> (Match -> Match -> Match)
-> (Match -> Match -> Match)
-> Ord Match
Match -> Match -> Bool
Match -> Match -> Ordering
Match -> Match -> Match
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Match -> Match -> Match
$cmin :: Match -> Match -> Match
max :: Match -> Match -> Match
$cmax :: Match -> Match -> Match
>= :: Match -> Match -> Bool
$c>= :: Match -> Match -> Bool
> :: Match -> Match -> Bool
$c> :: Match -> Match -> Bool
<= :: Match -> Match -> Bool
$c<= :: Match -> Match -> Bool
< :: Match -> Match -> Bool
$c< :: Match -> Match -> Bool
compare :: Match -> Match -> Ordering
$ccompare :: Match -> Match -> Ordering
$cp1Ord :: Eq Match
Ord, Int -> Match -> ShowS
[Match] -> ShowS
Match -> Identifier
(Int -> Match -> ShowS)
-> (Match -> Identifier) -> ([Match] -> ShowS) -> Show Match
forall a.
(Int -> a -> ShowS)
-> (a -> Identifier) -> ([a] -> ShowS) -> Show a
showList :: [Match] -> ShowS
$cshowList :: [Match] -> ShowS
show :: Match -> Identifier
$cshow :: Match -> Identifier
showsPrec :: Int -> Match -> ShowS
$cshowsPrec :: Int -> Match -> ShowS
Show)

-- | @match pat s@ applies the pattern @pat@ to @s@ and returns a
-- 'Match' describing the kind of match if any, or 'Nothing'
-- otherwise.  The pattern is interpreted as tokens delimited by
-- whitespace, and each token must be present somewhere in @s@.
match :: T.Text -> T.Text -> Maybe Match
match :: Text -> Text -> Maybe Match
match Text
pat Text
s
  | Text
pat Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s = Match -> Maybe Match
forall a. a -> Maybe a
Just Match
ExactMatch
  | Bool
otherwise =
    case Text -> [Text]
T.words Text
pat of
      []         -> Match -> Maybe Match
forall a. a -> Maybe a
Just Match
PrefixMatch
      pat' :: [Text]
pat'@(Text
x:[Text]
_) | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Text -> Bool
look [Text]
pat' -> if Text
x Text -> Text -> Bool
`T.isPrefixOf` Text
s
                                    then Match -> Maybe Match
forall a. a -> Maybe a
Just Match
PrefixMatch
                                    else Match -> Maybe Match
forall a. a -> Maybe a
Just Match
InfixMatch
                 | Bool
otherwise     -> Maybe Match
forall a. Maybe a
Nothing
        where look :: Text -> Bool
look Text
tok = Text
tok Text -> Text -> Bool
`T.isInfixOf` Text
s

-- | @filterMatches f pat l@ returns only those elements of @l@ that
-- match @pat@, using @f@ to convert each element to a 'T.Text'.  The
-- result will be ordered equivalently to @l@
filterMatches :: (a -> T.Text) -> T.Text -> [a] -> [a]
filterMatches :: (a -> Text) -> Text -> [a] -> [a]
filterMatches a -> Text
f Text
pat = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Match -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Match -> Bool) -> (a -> Maybe Match) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Maybe Match
match Text
pat (Text -> Maybe Match) -> (a -> Text) -> a -> Maybe Match
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
f)

-- | @sortMatches f pat l@ returns only those elements of @l@ that
-- match @pat@, using @f@ to convert each element to a 'T.Text'.  The
-- result will be reordered such that exact matches come first, then
-- prefixes, then infixes, although original order will be maintained
-- within these three groups.
sortMatches :: (a -> T.Text) -> T.Text -> [a] -> [a]
sortMatches :: (a -> Text) -> Text -> [a] -> [a]
sortMatches a -> Text
f Text
t [a]
ts = ((Match, a) -> a) -> [(Match, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Match, a) -> a
forall a b. (a, b) -> b
snd ([(Match, a)] -> [a]) -> [(Match, a)] -> [a]
forall a b. (a -> b) -> a -> b
$ [(Match, a)]
exacts[(Match, a)] -> [(Match, a)] -> [(Match, a)]
forall a. [a] -> [a] -> [a]
++[(Match, a)]
prefixes[(Match, a)] -> [(Match, a)] -> [(Match, a)]
forall a. [a] -> [a] -> [a]
++[(Match, a)]
infixes
  where attach :: a -> Maybe (Match, a)
attach a
y = do Match
m <- Text -> Text -> Maybe Match
match Text
t (Text -> Maybe Match) -> Text -> Maybe Match
forall a b. (a -> b) -> a -> b
$ a -> Text
f a
y
                      (Match, a) -> Maybe (Match, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Match
m, a
y)
        matches :: [(Match, a)]
matches = (a -> Maybe (Match, a)) -> [a] -> [(Match, a)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe (Match, a)
attach [a]
ts
        ([(Match, a)]
exacts, [(Match, a)]
nonexacts) = ((Match, a) -> Bool)
-> [(Match, a)] -> ([(Match, a)], [(Match, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Match -> Match -> Bool
forall a. Eq a => a -> a -> Bool
==Match
ExactMatch) (Match -> Bool) -> ((Match, a) -> Match) -> (Match, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Match, a) -> Match
forall a b. (a, b) -> a
fst) [(Match, a)]
matches
        ([(Match, a)]
prefixes, [(Match, a)]
infixes) =
          ((Match, a) -> Bool)
-> [(Match, a)] -> ([(Match, a)], [(Match, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Match -> Match -> Bool
forall a. Eq a => a -> a -> Bool
==Match
PrefixMatch) (Match -> Bool) -> ((Match, a) -> Match) -> (Match, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Match, a) -> Match
forall a b. (a, b) -> a
fst) [(Match, a)]
nonexacts