{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Sindre.Sindre
-- License     :  MIT-style (see LICENSE)
--
-- Stability   :  provisional
-- Portability :  portable
--
-- General definitions for the Sindre programming language.  The
-- documentation for this module does not include a description of the
-- language semantics.
--
-----------------------------------------------------------------------------
module Sindre.Sindre ( 
  -- * Screen layout
  Rectangle(..),
  DimNeed(..),
  SpaceNeed,
  SpaceUse,
  Constraints,
  Align(..),
  -- ** Layouting functions
  constrainNeed,
  fitRect,
  splitHoriz,
  splitVert,
  rectTranspose,
  align,
  adjustRect,
  -- * Keyboard Input
  KeyModifier(..),
  Key(..),
  Chord,
  -- * Input positions
  P(..),
  at,
  SourcePos,
  nowhere,
  position,
  -- * Abstract syntax tree
  Identifier,
  Stmt(..),
  Expr(..),
  ObjectNum,
  ObjectRef,
  WidgetRef,
  -- ** Value representation
  Value(..),
  string,
  true,
  truth,
  falsity,
  -- ** Program structure
  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

-- | A rectangle represented as its upper-left corner, width and
-- height.  You should never create rectangles with negative
-- dimensions, and the functions in this module make no guarantee to
-- their behaviour if you do.
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+w1-x') (x2+w2-x'))
                                  (max (y1+h1-y') (y2+h2-y'))
    where (x', y') = (min x1 x2, min y1 y2)

-- | Flip the x and y coordinates and width and height of a rectangle,
-- in a sense rotating it ninety degrees.  Note that @rectTranspose
-- . rectTranspose = id@.
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..n-2] ++ [c+r]
  where (c,r) = total `quotRem` n

-- | @splitHoriz rect dims@ splits @rect@ horizontally into a number
-- of non-overlapping equal-width rectangles stacked on top of each
-- other.  @dims@ is a list of height requirements that the function
-- will attempt to fulfill as best it is able.  The union of the list
-- of returned rectangles will always be equal to @rect@.  No
-- rectangle will ever have negative dimensions.
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 (v-mv)
                                           in ((v-d', Min mv), d-d')
                             | otherwise = ((v-d, Min mv), 0)
          grab d (v, Max mv) | d > 0     = let d' = min v d
                                           in ((v-d', Max mv), d-d')
                             | otherwise = let d' = max (v-mv) d
                                           in ((v-d', Max mv), d-d')
          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 $ v-ev
                                          in ((v-d', Exact ev), d-d')
                               | v < ev = let d' = min v $ min d $ ev-v
                                          in ((v-d', Exact ev), d-d')
                               | 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 (mv-v) (map (,True) bef) (map (,True) aft)
            in (map fst bef', (v+(mv-v)-d, f mv), map fst aft')

-- | As @splitHoriz@, but splits vertically instead of horizontally,
-- so the rectangles will be next to each other.
splitVert :: Rectangle -> [DimNeed] -> [Rectangle]
splitVert r = map rectTranspose . splitHoriz (rectTranspose r)

-- | A size constraint in one dimension.
data DimNeed = Min Integer -- ^ At minimum this many pixels.
             | Max Integer -- ^ At most this many pixels.
             | Unlimited -- ^ As many or as few pixels as necessary.
             | Exact Integer -- ^ Exactly this many pixels.
         deriving (Eq, Show, Ord)

-- | Size constraints in both dimensions.
type SpaceNeed = (DimNeed, DimNeed)

-- | The amount of space actually used by a widget.
type SpaceUse = [Rectangle]

-- | Externally-imposed optional minimum and maximum values for width
-- and height.
type Constraints = ( (Maybe Integer, Maybe Integer)
                   , (Maybe Integer, Maybe Integer))

-- | @constrainNeed need constraints@ reduces the space requirement
-- given by @need@ in order to fulfill @constraints@.
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 rect need@ yields a rectangle as large as possible, but
-- no larger than @rect@, that tries to fulfill the constraints
-- @need@.
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

-- | Instruction on how to align a smaller interval within a larger
-- interval.
data Align = AlignNeg -- ^ Align towards negative infinity.
           | AlignPos -- ^ Align towards positive infinity.
           | AlignCenter -- ^ Align towards the center of the interval.
             deriving (Show, Eq)

-- | @align a lower x upper@, where @lower<=upper@, aligns a
-- subinterval of length @x@ in the interval @lower@ to @upper@,
-- returning the coordinate at which the aligned subinterval starts.
-- For example,
--
-- >>> align AlignCenter 2 4 10
-- 4
-- >>> align AlignNeg 2 4 10
-- 2
-- >>> align AlignPos 2 4 10
-- 6
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 (walign, halign) bigrect smallrect@ returns a
-- rectangle with the same dimensions as @smallrect@ aligned within
-- @bigrect@ in both dimensions.
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

-- | A keyboard modifier key.  The precise meaning (and location) of
-- these is somewhat platform-dependent.  Note that the @Shift@
-- modifier should not be passed along if the associated key is a
-- @CharKey@, as @Shift@ will already have been handled.
data KeyModifier = Control | Meta | Super | Hyper | Shift
                   deriving (Eq, Ord, Show)

-- | Either a key corresponding to a visible character, or a control
-- key not associated with any character.
data Key = CharKey Char -- ^ Unicode character associated with the key.
         | CtrlKey String -- ^ Name of the control key, using X11
                          -- key names (for example @BackSpace@ or
                          -- @Return@).
    deriving (Show, Eq, Ord)

-- | A combination of a set of modifier keys and a primary key,
-- representing a complete piece of keyboard input.
type Chord = (S.Set KeyModifier, Key)

-- | Low-level reference to an object.
type ObjectNum = Int
-- | High-level reference to an object, containing its class and name
-- (if any) as well.  For non-widgets, the object name is the same as
-- the object class.
type ObjectRef = (ObjectNum, Identifier, Maybe Identifier)
-- | High-level reference to a widget.
type WidgetRef = ObjectRef

-- | The type of names (such as variables and classes) in the syntax
-- tree.
type Identifier = String

-- | Dynamically typed run-time value in the Sindre language.
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 s@ returns a Sindre string.
string :: String -> Value
string = StringV . T.pack

-- | @true v@ returns 'True' if @v@ is interpreted as a true value in
-- Sindre, 'False' otherwise.
true :: Value -> Bool
true (Number 0) = False
true (StringV s) = s /= T.empty
true (Dict m) = m /= M.empty
true _ = True

-- | Canonical false value, see 'true'.
truth, falsity :: Value
-- ^ Canonical true value, see 'true'.
truth = Number 1
falsity = Number 0

-- | A position in a source file, consisting of a file name,
-- one-indexed line number, and one-indexed column number.
type SourcePos = (String, Int, Int)

-- | A default position when no other is available.
nowhere :: SourcePos
nowhere = ("<nowhere>", 0, 0)

-- | Prettyprint a source position in a human-readable form.
--
-- >>> position ("foobar.sindre", 5, 15)
-- "foobar.sindre:5:15: "
position :: SourcePos -> String
position (file, line, col) =
  file ++ ":" ++ show line ++ ":" ++ show col ++ ": "

-- | Wrap a value with source position information.
data P a = P { sourcePos :: SourcePos, unP :: a }
    deriving (Show, Eq, Ord, Functor)

-- | @x `at` y@ gives a value containing @x@, but with the same source
-- position as @y@.
at :: a -> P b -> P a
at e1 e2 = const e1 <$> e2

-- | The syntax of Sindre statements.
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)

-- | The syntax of Sindre expressions.
data Expr = Literal Value
          | Var Identifier
          | FieldOf Identifier (P Expr)
          | Lookup (P Expr) (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)

-- | Something that happened in the world.
data Event = KeyPress Chord
           | NamedEvent { eventName   :: Identifier  -- ^ The name of the event.
                        , eventValue  :: [Value]     -- ^ The payload of the event.
                        , eventSource :: EventSource -- ^ Where it's from.
                        }
             deriving (Show)

-- | The origin of an event.  This is used when determining where to
-- handle it.
data EventSource = FieldSrc ObjectRef Identifier
                   -- ^ @FieldSrc obj f@ designates that the source of
                   -- the event is the property @f@ of @obj@
                 | ObjectSrc ObjectRef -- ^ The source is the given object.
                 | BackendSrc -- ^ The source is something within the
                              -- bowels of the active backend,
                              -- probably from the external world.
        deriving (Show)

-- | Description of sets of sources, values of this type can be used
-- to pattern-match @EventSource@s.
data SourcePat = NamedSource Identifier (Maybe Identifier)
               -- ^ For @NamedSource k fk@, the source must be the
               -- object named @k@.  If @fk@ is @Just fk'@, the source
               -- must also be the field named @fk'@.
               | GenericSource Identifier Identifier (Maybe Identifier)
                 -- ^ For @GenericSource cn k fk@, the source must be
                 -- of class @cn@.  If @fk@ is @Just fk'@, the source
                 -- must also be the field named @fk'@.  The variable
                 -- named @k@ should be bound to the actual object if
                 -- this pattern matches.
                 deriving (Eq, Ord, Show)

-- | A description of an event used to indicate how to handle
-- different events.
data Pattern = ChordPattern Chord -- ^ Match if the event is a chord.
             | OrPattern Pattern Pattern -- ^ Match if either pattern
                                         -- matches.
             | SourcedPattern { patternSource :: SourcePat
                              , patternEvent  :: Identifier
                              , patternVars   :: [Identifier]
                              }
               -- ^ @SourcedPattern src ev vars@ matches if @src@
               -- matches the event source (see 'SourcePat') an @ev@
               -- matches the event name.  @vars@ should be bound to
               -- the values in the payload of the event.
               deriving (Eq, Ord, Show)

-- | A function consists of lexically bound parameters and a body.
data Function = Function [Identifier] [P Stmt]
              deriving (Show, Eq)

-- | Reaction to an event.
data Action = StmtAction [P Stmt] -- ^ Execute these statements.
              deriving (Show)

-- | Widget arguments are key-value pairs, with a unique value for
-- each key.
type WidgetArgs = M.Map Identifier (P Expr)

-- | A Sindre GUI is a recursive tree, with each node representing a
-- single widget and consisting of the following fields.
data GUI = GUI {
      widgetName :: Maybe Identifier -- ^ Name of the widget, if any.
    , widgetClass :: P Identifier -- ^ Class of the widget.
    , widgetArgs :: WidgetArgs -- ^ The arguments passed to the widget.
    , widgetChildren :: [(Maybe (P Expr), GUI)] -- ^ Children of the widget, if any.
    } deriving (Show)

-- | A command line argument.
type SindreOption = OptDescr (Arguments -> Arguments)
-- | The arguments passed to the Sindre program from the command line.
type Arguments = M.Map String String

-- | A complete Sindre program.  Note that this is intentionally
-- defined such that some invalid programs, like those with duplicate
-- definitions can be represented - the compiler (see
-- "Sindre.Compiler") should detect and handle such errors.
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] -- ^ The contents of the @BEGIN@ block.
    }