live-sequencer-0.0.6.1: src/ControllerBase.hs

{-
This is a part of the Controller module
that is separated in order to prevent an import cycle.
-}
module ControllerBase where

import qualified Exception
import qualified Term
import Term ( Term )
import SourceText ( ModuleRange )

import qualified Data.Map as Map
import Data.Map ( Map )

import qualified Control.Monad.Exception.Synchronous as ME

import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import qualified Data.Traversable as Trav



data Control =
      CheckBox Bool
    | Slider Int Int Int

data Value = Bool Bool | Number Int
    deriving Show

data Values =
    Values {
        boolValues :: Map Name Bool,
        numberValues :: Map Name Int
     } deriving Show

newtype Name = Name String
    deriving (Eq, Ord, Show)

deconsName :: Name -> String
deconsName (Name name) = name


emptyValues :: Values
emptyValues = Values Map.empty Map.empty

updateValues :: Values -> Assignments -> Assignments
updateValues (Values bools numbers) assigns =
    Map.union
        (Map.intersectionWith
            (\b (rng, a) -> (rng,
                case a of
                    CheckBox _deflt -> CheckBox b
                    _ -> a))
            bools assigns) $
    Map.union
        (Map.intersectionWith
            (\x (rng, a) -> (rng,
                case a of
                    Slider lower upper _deflt -> Slider lower upper x
                    _ -> a))
            numbers assigns) $
    assigns


type Assignments = Map Name (ModuleRange, Control)


exc :: Term ModuleRange -> String -> ME.Exceptional Exception.Message a
exc t = ME.Exception . Exception.messageParseModuleRange (Term.termRange t)

excDuplicate :: Name -> ModuleRange -> Exception.Message
excDuplicate name rng =
    Exception.messageParseModuleRange rng $
        "duplicate controller definition with name "
         ++ deconsName name

union :: Assignments -> Assignments -> Exception.Monad Assignments
union m0 m1 =
    let f = fmap ME.Success
    in  Trav.sequenceA $
        Map.unionWithKey
            (\name _ a -> do
                (rng, _c) <- a
                ME.throw $ excDuplicate name rng)
            (f m0) (f m1)

collect :: Term ModuleRange -> Exception.Monad Assignments
collect topTerm =
    flip MS.execStateT Map.empty $
    mapM_
        (\ea -> do
            (name, rc@(rng, _ctrl)) <- MT.lift ea
            MT.lift . ME.assert (excDuplicate name rng)
                =<< MS.gets (Map.notMember name)
            MS.modify (Map.insert name rc)) $ do

    ( _pos, term ) <- Term.subterms topTerm
    case Term.viewNode term of
        Just ( "checkBox" , args ) ->
            return $
            case args of
                [ Term.StringLiteral _rng tag,
                  defltTerm@(Term.Node deflt []) ] ->
                    case reads $ Term.name deflt of
                        [(b, "")] ->
                            ME.Success
                                (Name tag, (Term.termRange term, CheckBox b))
                        _ ->
                            exc defltTerm $
                            "cannot parse Bool value " ++
                            show (Term.name deflt) ++ " for checkBox"
                _ -> exc term "invalid checkBox arguments"
        Just ( "slider" , args ) ->
            return $
            case args of
                [ Term.StringLiteral _rngT tag, lower, upper, deflt ] -> do
                    let milliard = 1000000000
                        number arg =
                            Exception.checkRange
                                Exception.messageParseModuleRange
                                arg id id (-milliard) milliard
                    l <- number "lower slider bound" lower
                    u <- number "upper slider bound" upper
                    x <- number "default slider value" deflt
                    return (Name tag, (Term.termRange term, Slider l u x))
                _ -> exc term "invalid slider arguments"
        _ -> []