module Sindre.Sindre (
Rectangle(..),
DimNeed(..),
SpaceNeed,
SpaceUse,
Constraints,
Align(..),
constrainNeed,
fitRect,
splitHoriz,
splitVert,
rectTranspose,
align,
adjustRect,
KeyModifier(..),
Key(..),
Chord,
P(..),
at,
SourcePos,
nowhere,
position,
Identifier,
Stmt(..),
Expr(..),
ObjectNum,
ObjectRef,
WidgetRef,
Value(..),
string,
true,
truth,
falsity,
Event(..),
EventSource(..),
SourcePat(..),
Pattern(..),
Action(..),
Function(..),
GUI(..),
Program(..),
SindreOption,
Arguments
)
where
import System.Console.GetOpt
import Control.Applicative
import Data.List
import qualified Data.Map as M
import Data.Monoid
import qualified Data.Set as S
import qualified Data.Text as T
data Rectangle = Rectangle {
rectX :: Integer
, rectY :: Integer
, rectWidth :: Integer
, rectHeight :: Integer
} deriving (Show, Eq)
instance Monoid Rectangle where
mempty = Rectangle 0 0 (1) (1)
mappend r1@(Rectangle x1 y1 w1 h1) r2@(Rectangle x2 y2 w2 h2)
| r1 == mempty = r2
| r2 == mempty = r1
| otherwise = Rectangle x' y' (max (x1+w1x') (x2+w2x'))
(max (y1+h1y') (y2+h2y'))
where (x', y') = (min x1 x2, min y1 y2)
rectTranspose :: Rectangle -> Rectangle
rectTranspose (Rectangle x y w h) = Rectangle y x h w
zipper :: (([a], a, [a]) -> ([a], a, [a])) -> [a] -> [a]
zipper f = zipper' []
where zipper' a (x:xs) = let (a', x', xs') = f (a, x, xs)
in zipper' (x':a') xs'
zipper' a [] = reverse a
divide :: Integral a => a -> a -> [a]
divide total n = map (const c) [0..n2] ++ [c+r]
where (c,r) = total `quotRem` n
splitHoriz :: Rectangle -> [DimNeed] -> [Rectangle]
splitHoriz (Rectangle x1 y1 w h) parts =
snd $ mapAccumL mkRect y1 $ map fst $
zipper adjust $ zip (divide h nparts) parts
where nparts = genericLength parts
mkRect y h' = (y+h', Rectangle x1 y w h')
grab d (v, Min mv) | d > 0 = let d' = max 0 $ min d (vmv)
in ((vd', Min mv), dd')
| otherwise = ((vd, Min mv), 0)
grab d (v, Max mv) | d > 0 = let d' = min v d
in ((vd', Max mv), dd')
| otherwise = let d' = max (vmv) d
in ((vd', Max mv), dd')
grab d (v, Unlimited) = let v' = max 0 $ v d
in ((v', Unlimited), v'v+d)
grab d (v, Exact ev) | v > ev = let d' = min v $ min d $ vev
in ((vd', Exact ev), dd')
| v < ev = let d' = min v $ min d $ evv
in ((vd', Exact ev), dd')
| otherwise = ((v, Exact ev), d)
maybeGrab (d:ds) ((x, True):xs) =
(case grab d x of (x',0) -> ((x',True),0)
(x',d') -> ((x',False),d')) : maybeGrab ds xs
maybeGrab ds ((x, False):xs) = ((x,False),0) : maybeGrab ds xs
maybeGrab _ _ = []
obtain v bef aft =
case (filter snd bef, filter snd aft) of
([],[]) -> (bef,aft,v)
(bef',aft') ->
let q = divide v $ genericLength $ bef'++aft'
n = length bef'
(bef'',x) = unzip $ maybeGrab q bef
(aft'',y) = unzip $ maybeGrab (drop n q) aft
r = sum x + sum y
in if r /= 0 then obtain r bef'' aft'' else (bef'',aft'', r)
adjust (bef, (v, Min mv), aft)
| v < mv = adjust' Min bef v mv aft
adjust (bef, (v, Max mv), aft)
| v > mv = adjust' Max bef v mv aft
adjust (bef, (v, Exact ev), aft)
| v /= ev = adjust' Exact bef v ev aft
adjust x = x
adjust' f bef v mv aft =
let (bef', aft', d) =
obtain (mvv) (map (,True) bef) (map (,True) aft)
in (map fst bef', (v+(mvv)d, f mv), map fst aft')
splitVert :: Rectangle -> [DimNeed] -> [Rectangle]
splitVert r = map rectTranspose . splitHoriz (rectTranspose r)
data DimNeed = Min Integer
| Max Integer
| Unlimited
| Exact Integer
deriving (Eq, Show, Ord)
type SpaceNeed = (DimNeed, DimNeed)
type SpaceUse = [Rectangle]
type Constraints = ( (Maybe Integer, Maybe Integer)
, (Maybe Integer, Maybe Integer))
constrainNeed :: SpaceNeed -> Constraints -> SpaceNeed
constrainNeed (wreq, hreq) ((minw, maxw), (minh, maxh)) =
(f wreq minw maxw, f hreq minh maxh)
where f x Nothing Nothing = x
f (Max x) (Just y) _ | x > y = Min x
f (Max _) (Just y) _ = Max y
f (Min x) (Just y) _ = Min $ max x y
f _ (Just y) _ = Min y
f _ _ (Just y) = Max y
fitRect :: Rectangle -> SpaceNeed -> Rectangle
fitRect (Rectangle x y w h) (wn, hn) =
Rectangle x y (fit w wn) (fit h hn)
where fit d dn = case dn of
Max dn' -> min d dn'
Min _ -> d
Exact ev -> min d ev
Unlimited -> d
data Align = AlignNeg
| AlignPos
| AlignCenter
deriving (Show, Eq)
align :: Integral a => Align -> a -> a -> a -> a
align AlignCenter minp d maxp = minp + (maxp minp d) `div` 2
align AlignNeg minp _ _ = minp
align AlignPos _ d maxp = maxp d
adjustRect :: (Align, Align) -> Rectangle -> Rectangle -> Rectangle
adjustRect (walign, halign) (Rectangle sx sy sw sh) (Rectangle _ _ w h) =
Rectangle cx' cy' w h
where cx' = frob walign sx w sw
cy' = frob halign sy h sh
frob AlignCenter c d maxv = c + (maxv d) `div` 2
frob AlignNeg c _ _ = c
frob AlignPos c d maxv = c + maxv d
data KeyModifier = Control | Meta | Super | Hyper | Shift
deriving (Eq, Ord, Show)
data Key = CharKey Char
| CtrlKey String
deriving (Show, Eq, Ord)
type Chord = (S.Set KeyModifier, Key)
type ObjectNum = Int
type ObjectRef = (ObjectNum, Identifier, Maybe Identifier)
type WidgetRef = ObjectRef
type Identifier = String
data Value = StringV T.Text
| Number Double
| Reference ObjectRef
| Dict (M.Map Value Value)
deriving (Eq, Ord)
instance Show Value where
show (Number v) = if fromInteger v' == v then show v'
else show v
where v' = round v
show (Reference (_,_,Just k)) = k
show (Reference (r,c,Nothing)) = "#<" ++ c ++ " at " ++ show r ++ ">"
show (Dict m) = "#<dictionary with "++show (M.size m)++" entries>"
show (StringV v) = T.unpack v
string :: String -> Value
string = StringV . T.pack
true :: Value -> Bool
true (Number 0) = False
true (StringV s) = s /= T.empty
true (Dict m) = m /= M.empty
true _ = True
truth, falsity :: Value
truth = Number 1
falsity = Number 0
type SourcePos = (String, Int, Int)
nowhere :: SourcePos
nowhere = ("<nowhere>", 0, 0)
position :: SourcePos -> String
position (file, line, col) =
file ++ ":" ++ show line ++ ":" ++ show col ++ ": "
data P a = P { sourcePos :: SourcePos, unP :: a }
deriving (Show, Eq, Ord, Functor)
at :: a -> P b -> P a
at e1 e2 = const e1 <$> e2
data Stmt = Print [P Expr]
| Exit (Maybe (P Expr))
| Return (Maybe (P Expr))
| Next
| If (P Expr) [P Stmt] [P Stmt]
| While (P Expr) [P Stmt]
| For (P Expr) (P Expr) (P Expr) [P Stmt]
| Do [P Stmt] (P Expr)
| Break
| Continue
| Expr (P Expr)
| Focus (P Expr)
deriving (Show, Eq)
data Expr = Literal Value
| Var Identifier
| FieldOf Identifier (P Expr)
| Lookup Identifier (P Expr)
| Not (P Expr)
| LessThan (P Expr) (P Expr)
| LessEql (P Expr) (P Expr)
| Equal (P Expr) (P Expr)
| Assign (P Expr) (P Expr)
| PostInc (P Expr)
| PostDec (P Expr)
| Concat (P Expr) (P Expr)
| Plus (P Expr) (P Expr)
| Minus (P Expr) (P Expr)
| Times (P Expr) (P Expr)
| Divided (P Expr) (P Expr)
| Modulo (P Expr) (P Expr)
| RaisedTo (P Expr) (P Expr)
| Funcall Identifier [P Expr]
| Methcall (P Expr) Identifier [P Expr]
| Cond (P Expr) (P Expr) (P Expr)
deriving (Show, Eq, Ord)
data Event = KeyPress Chord
| NamedEvent { eventName :: Identifier
, eventValue :: [Value]
, eventSource :: EventSource
}
deriving (Show)
data EventSource = FieldSrc ObjectRef Identifier
| ObjectSrc ObjectRef
| BackendSrc
deriving (Show)
data SourcePat = NamedSource Identifier (Maybe Identifier)
| GenericSource Identifier Identifier (Maybe Identifier)
deriving (Eq, Ord, Show)
data Pattern = ChordPattern Chord
| OrPattern Pattern Pattern
| SourcedPattern { patternSource :: SourcePat
, patternEvent :: Identifier
, patternVars :: [Identifier]
}
deriving (Eq, Ord, Show)
data Function = Function [Identifier] [P Stmt]
deriving (Show, Eq)
data Action = StmtAction [P Stmt]
deriving (Show)
type WidgetArgs = M.Map Identifier (P Expr)
data GUI = GUI {
widgetName :: Maybe Identifier
, widgetClass :: P Identifier
, widgetArgs :: WidgetArgs
, widgetChildren :: [(Maybe (P Expr), GUI)]
} deriving (Show)
type SindreOption = OptDescr (Arguments -> Arguments)
type Arguments = M.Map String String
data Program = Program {
programGUI :: (Maybe (P Expr), GUI)
, programActions :: [P (Pattern, Action)]
, programGlobals :: [P (Identifier, P Expr)]
, programOptions :: [P (Identifier, (SindreOption, Maybe Value))]
, programFunctions :: [P (Identifier, Function)]
, programBegin :: [P Stmt]
}