-- Copyright 2014 Evan Laforge -- This program is distributed under the terms of the GNU General Public -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt {-# LANGUAGE RankNTypes #-} -- | Utilities for the Library type. module Derive.Library ( -- * make Library, library, generators, transformers, vals, pattern , ToLibrary, Entry(..) , Calls(..), both , poly_generators, poly_transformers -- * compile , Shadowed, compile, compile_log ) where import qualified Data.Either as Either import qualified Data.Map.Strict as Map import qualified Util.Log as Log import qualified Util.Logger as Logger import qualified Util.Maps as Maps import qualified Util.Lists as Lists import qualified Derive.Call.Module as Module import qualified Derive.Derive as Derive import qualified Derive.Expr as Expr import Global -- | The holds the libary of statically-declared calls. It gets compiled to -- 'Derive.Builtins' by 'compile'. type Library = Derive.ScopesT (Derive.Scope [Entry (Derive.Generator Derive.Note)] [Entry (Derive.Generator Derive.Control)] [Entry (Derive.Generator Derive.Pitch)]) (Derive.Scope [Entry (Derive.Transformer Derive.Note)] [Entry (Derive.Transformer Derive.Control)] [Entry (Derive.Transformer Derive.Pitch)]) (Derive.Scope [Entry (Derive.TrackCall Derive.Note)] [Entry (Derive.TrackCall Derive.Control)] [Entry (Derive.TrackCall Derive.Pitch)]) [Entry Derive.ValCall] data Entry call = Single !Expr.Symbol !call | Pattern !(Derive.PatternCall call) instance Show Library where show :: Library -> String show Library _ = String "((Library))" instance Pretty (Entry call) where pretty :: Entry call -> Text pretty (Single Symbol sym call _) = Symbol -> Text Expr.unsym Symbol sym pretty (Pattern PatternCall call pattern) = Text "pattern:" forall a. Semigroup a => a -> a -> a <> forall call. PatternCall call -> Text Derive.pat_description PatternCall call pattern -- * make library :: ToLibrary call => [(Expr.Symbol, call)] -> Library library :: forall call. ToLibrary call => [(Symbol, call)] -> Library library [] = forall a. Monoid a => a mempty library [(Symbol, call)] calls = forall call. ToLibrary call => [Entry call] -> Library -> Library to_library (forall a b. (a -> b) -> [a] -> [b] map (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry forall call. Symbol -> call -> Entry call Single) [(Symbol, call)] calls) forall a. Monoid a => a mempty -- | This is just a specialization of 'library', just for documentation. generators :: ToLibrary (Derive.Generator call) => [(Expr.Symbol, Derive.Generator call)] -> Library generators :: forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library generators = forall call. ToLibrary call => [(Symbol, call)] -> Library library -- | This is just a specialization of 'library', just for documentation. transformers :: ToLibrary (Derive.Transformer call) => [(Expr.Symbol, Derive.Transformer call)] -> Library transformers :: forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library transformers = forall call. ToLibrary call => [(Symbol, call)] -> Library library -- | This is just a specialization of 'library', just for documentation. vals :: [(Expr.Symbol, Derive.ValCall)] -> Library vals :: [(Symbol, ValCall)] -> Library vals = forall call. ToLibrary call => [(Symbol, call)] -> Library library pattern :: ToLibrary call => Derive.PatternCall call -> Library pattern :: forall call. ToLibrary call => PatternCall call -> Library pattern PatternCall call c = forall call. ToLibrary call => [Entry call] -> Library -> Library to_library [forall call. PatternCall call -> Entry call Pattern PatternCall call c] forall a. Monoid a => a mempty -- | Bundle a generator and transformer together, so I can define them -- together. Functions to create these are in "Derive.Call.Make". data Calls d = Calls { forall d. Calls d -> Generator d generator :: !(Derive.Generator d) , forall d. Calls d -> Transformer d transformer :: !(Derive.Transformer d) } both :: (ToLibrary (Derive.Generator d), ToLibrary (Derive.Transformer d)) => [(Expr.Symbol, Calls d)] -> Library both :: forall d. (ToLibrary (Generator d), ToLibrary (Transformer d)) => [(Symbol, Calls d)] -> Library both [(Symbol, Calls d)] sym_calls = forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library generators (forall a b. [a] -> [b] -> [(a, b)] zip [Symbol] syms (forall a b. (a -> b) -> [a] -> [b] map forall d. Calls d -> Generator d generator [Calls d] calls)) forall a. Semigroup a => a -> a -> a <> forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library transformers (forall a b. [a] -> [b] -> [(a, b)] zip [Symbol] syms (forall a b. (a -> b) -> [a] -> [b] map forall d. Calls d -> Transformer d transformer [Calls d] calls)) where ([Symbol] syms, [Calls d] calls) = forall a b. [(a, b)] -> ([a], [b]) unzip [(Symbol, Calls d)] sym_calls -- | Add a polymorphic generator to all call types. -- -- The Callable constraint is not needed here, but callers will have it, and -- for some reason you can't coerce a parametric variable into a constrained -- one. poly_generators :: (forall d. Derive.CallableExpr d => [(Expr.Symbol, Derive.Generator d)]) -> Library poly_generators :: (forall d. CallableExpr d => [(Symbol, Generator d)]) -> Library poly_generators forall d. CallableExpr d => [(Symbol, Generator d)] calls = forall a. Monoid a => [a] -> a mconcat [ forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library generators (forall d. CallableExpr d => [(Symbol, Generator d)] calls :: [(Expr.Symbol, Derive.Generator Derive.Note)]) , forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library generators (forall d. CallableExpr d => [(Symbol, Generator d)] calls :: [(Expr.Symbol, Derive.Generator Derive.Control)]) , forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library generators (forall d. CallableExpr d => [(Symbol, Generator d)] calls :: [(Expr.Symbol, Derive.Generator Derive.Pitch)]) ] poly_transformers :: (forall d. Derive.CallableExpr d => [(Expr.Symbol, Derive.Transformer d)]) -> Library poly_transformers :: (forall d. CallableExpr d => [(Symbol, Transformer d)]) -> Library poly_transformers forall d. CallableExpr d => [(Symbol, Transformer d)] calls = forall a. Monoid a => [a] -> a mconcat [ forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library transformers (forall d. CallableExpr d => [(Symbol, Transformer d)] calls :: [(Expr.Symbol, Derive.Transformer Derive.Note)]) , forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library transformers (forall d. CallableExpr d => [(Symbol, Transformer d)] calls :: [(Expr.Symbol, Derive.Transformer Derive.Control)]) , forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library transformers (forall d. CallableExpr d => [(Symbol, Transformer d)] calls :: [(Expr.Symbol, Derive.Transformer Derive.Pitch)]) ] -- ** ToLibrary class ToLibrary call where to_library :: [Entry call] -> Library -> Library instance ToLibrary (Derive.Generator Derive.Note) where to_library :: [Entry (Generator Note)] -> Library -> Library to_library = (forall {gen} {trans} {track} {val}. ScopesT gen trans track val :-> gen Derive.s_generatorforall a b c. Lens a b -> Lens b c -> Lens a c #forall {note} {control} {pitch}. Scope note control pitch :-> note Derive.s_note #=) instance ToLibrary (Derive.Generator Derive.Control) where to_library :: [Entry (Generator Control)] -> Library -> Library to_library = (forall {gen} {trans} {track} {val}. ScopesT gen trans track val :-> gen Derive.s_generatorforall a b c. Lens a b -> Lens b c -> Lens a c #forall {note} {control} {pitch}. Scope note control pitch :-> control Derive.s_control #=) instance ToLibrary (Derive.Generator Derive.Pitch) where to_library :: [Entry (Generator Pitch)] -> Library -> Library to_library = (forall {gen} {trans} {track} {val}. ScopesT gen trans track val :-> gen Derive.s_generatorforall a b c. Lens a b -> Lens b c -> Lens a c #forall {note} {control} {pitch}. Scope note control pitch :-> pitch Derive.s_pitch #=) instance ToLibrary (Derive.Transformer Derive.Note) where to_library :: [Entry (Transformer Note)] -> Library -> Library to_library = (forall {gen} {trans} {track} {val}. ScopesT gen trans track val :-> trans Derive.s_transformerforall a b c. Lens a b -> Lens b c -> Lens a c #forall {note} {control} {pitch}. Scope note control pitch :-> note Derive.s_note #=) instance ToLibrary (Derive.Transformer Derive.Control) where to_library :: [Entry (Transformer Control)] -> Library -> Library to_library = (forall {gen} {trans} {track} {val}. ScopesT gen trans track val :-> trans Derive.s_transformerforall a b c. Lens a b -> Lens b c -> Lens a c #forall {note} {control} {pitch}. Scope note control pitch :-> control Derive.s_control #=) instance ToLibrary (Derive.Transformer Derive.Pitch) where to_library :: [Entry (Transformer Pitch)] -> Library -> Library to_library = (forall {gen} {trans} {track} {val}. ScopesT gen trans track val :-> trans Derive.s_transformerforall a b c. Lens a b -> Lens b c -> Lens a c #forall {note} {control} {pitch}. Scope note control pitch :-> pitch Derive.s_pitch #=) instance ToLibrary (Derive.TrackCall Derive.Note) where to_library :: [Entry (TrackCall Note)] -> Library -> Library to_library = (forall {gen} {trans} {track} {val}. ScopesT gen trans track val :-> track Derive.s_trackforall a b c. Lens a b -> Lens b c -> Lens a c #forall {note} {control} {pitch}. Scope note control pitch :-> note Derive.s_note #=) instance ToLibrary (Derive.TrackCall Derive.Control) where to_library :: [Entry (TrackCall Control)] -> Library -> Library to_library = (forall {gen} {trans} {track} {val}. ScopesT gen trans track val :-> track Derive.s_trackforall a b c. Lens a b -> Lens b c -> Lens a c #forall {note} {control} {pitch}. Scope note control pitch :-> control Derive.s_control #=) instance ToLibrary (Derive.TrackCall Derive.Pitch) where to_library :: [Entry (TrackCall Pitch)] -> Library -> Library to_library = (forall {gen} {trans} {track} {val}. ScopesT gen trans track val :-> track Derive.s_trackforall a b c. Lens a b -> Lens b c -> Lens a c #forall {note} {control} {pitch}. Scope note control pitch :-> pitch Derive.s_pitch #=) instance ToLibrary Derive.ValCall where to_library :: [Entry ValCall] -> Library -> Library to_library = (forall {gen} {trans} {track} {val}. ScopesT gen trans track val :-> val Derive.s_val #=) -- * compile -- | Warnings for shadowed symbols. ((call_type, module), symbols) type Shadowed = ((Text, Module.Module), [Expr.Symbol]) -- | Convert Library to Builtins. This indexes by module and also gives me -- a place to emit warnings about duplicate symbol names. compile :: Library -> (Derive.Builtins, [Shadowed]) compile :: Library -> (Builtins, [Shadowed]) compile (Derive.Scopes Scope [Entry (Generator Note)] [Entry (Generator Control)] [Entry (Generator Pitch)] lgen Scope [Entry (Transformer Note)] [Entry (Transformer Control)] [Entry (Transformer Pitch)] ltrans Scope [Entry (TrackCall Note)] [Entry (TrackCall Control)] [Entry (TrackCall Pitch)] ltrack [Entry ValCall] lval) = forall w a. Logger w a -> (a, [w]) Logger.runId forall a b. (a -> b) -> a -> b $ forall gen trans track val. gen -> trans -> track -> val -> ScopesT gen trans track val Derive.Scopes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall {a} {f :: * -> *} {call} {call} {call}. (MonadLogger ((a, Module), [Symbol]) f, IsString a) => (call -> CallDoc) -> (call -> CallDoc) -> (call -> CallDoc) -> Scope [Entry call] [Entry call] [Entry call] -> f (Scope (Map Module (CallMap call)) (Map Module (CallMap call)) (Map Module (CallMap call))) compile_scope forall func. Call func -> CallDoc Derive.call_doc forall func. Call func -> CallDoc Derive.call_doc forall func. Call func -> CallDoc Derive.call_doc Scope [Entry (Generator Note)] [Entry (Generator Control)] [Entry (Generator Pitch)] lgen forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall {a} {f :: * -> *} {call} {call} {call}. (MonadLogger ((a, Module), [Symbol]) f, IsString a) => (call -> CallDoc) -> (call -> CallDoc) -> (call -> CallDoc) -> Scope [Entry call] [Entry call] [Entry call] -> f (Scope (Map Module (CallMap call)) (Map Module (CallMap call)) (Map Module (CallMap call))) compile_scope forall func. Call func -> CallDoc Derive.call_doc forall func. Call func -> CallDoc Derive.call_doc forall func. Call func -> CallDoc Derive.call_doc Scope [Entry (Transformer Note)] [Entry (Transformer Control)] [Entry (Transformer Pitch)] ltrans forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall {a} {f :: * -> *} {call} {call} {call}. (MonadLogger ((a, Module), [Symbol]) f, IsString a) => (call -> CallDoc) -> (call -> CallDoc) -> (call -> CallDoc) -> Scope [Entry call] [Entry call] [Entry call] -> f (Scope (Map Module (CallMap call)) (Map Module (CallMap call)) (Map Module (CallMap call))) compile_scope forall d. TrackCall d -> CallDoc Derive.tcall_doc forall d. TrackCall d -> CallDoc Derive.tcall_doc forall d. TrackCall d -> CallDoc Derive.tcall_doc Scope [Entry (TrackCall Note)] [Entry (TrackCall Control)] [Entry (TrackCall Pitch)] ltrack forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall {f :: * -> *} {a} {call}. MonadLogger ((a, Module), [Symbol]) f => a -> (call -> CallDoc) -> [Entry call] -> f (Map Module (CallMap call)) compile_entries Text "val" ValCall -> CallDoc Derive.vcall_doc [Entry ValCall] lval where compile_scope :: (call -> CallDoc) -> (call -> CallDoc) -> (call -> CallDoc) -> Scope [Entry call] [Entry call] [Entry call] -> f (Scope (Map Module (CallMap call)) (Map Module (CallMap call)) (Map Module (CallMap call))) compile_scope call -> CallDoc doc1 call -> CallDoc doc2 call -> CallDoc doc3 (Derive.Scope [Entry call] note [Entry call] control [Entry call] pitch) = forall note control pitch. note -> control -> pitch -> Scope note control pitch Derive.Scope forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall {f :: * -> *} {a} {call}. MonadLogger ((a, Module), [Symbol]) f => a -> (call -> CallDoc) -> [Entry call] -> f (Map Module (CallMap call)) compile_entries a "note" call -> CallDoc doc1 [Entry call] note forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall {f :: * -> *} {a} {call}. MonadLogger ((a, Module), [Symbol]) f => a -> (call -> CallDoc) -> [Entry call] -> f (Map Module (CallMap call)) compile_entries a "control" call -> CallDoc doc2 [Entry call] control forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall {f :: * -> *} {a} {call}. MonadLogger ((a, Module), [Symbol]) f => a -> (call -> CallDoc) -> [Entry call] -> f (Map Module (CallMap call)) compile_entries a "pitch" call -> CallDoc doc3 [Entry call] pitch compile_entries :: a -> (call -> CallDoc) -> [Entry call] -> f (Map Module (CallMap call)) compile_entries a kind call -> CallDoc get_doc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall k a. Eq k => [(k, a)] -> Map k a Map.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (forall {m :: * -> *} {a} {t} {call}. MonadLogger ((a, t), [Symbol]) m => a -> (t, [Entry call]) -> m (t, CallMap call) compile1 a kind) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])] Lists.keyedGroupSort (CallDoc -> Module Derive.cdoc_module forall b c a. (b -> c) -> (a -> b) -> a -> c . Entry call -> CallDoc entry_doc) where entry_doc :: Entry call -> CallDoc entry_doc (Single Symbol _ call call) = call -> CallDoc get_doc call call entry_doc (Pattern PatternCall call pattern) = forall call. PatternCall call -> CallDoc Derive.pat_call_doc PatternCall call pattern compile1 :: a -> (t, [Entry call]) -> m (t, CallMap call) compile1 a kind (t module_, [Entry call] entries) = do let ([(Symbol, call)] singles, [PatternCall call] patterns) = forall {b}. [Entry b] -> ([(Symbol, b)], [PatternCall b]) partition [Entry call] entries let (Map Symbol call cmap, [(Symbol, call)] dups) = forall a b. Ord a => [(a, b)] -> (Map a b, [(a, b)]) Maps.unique [(Symbol, call)] singles forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (forall (t :: * -> *) a. Foldable t => t a -> Bool null [(Symbol, call)] dups) forall a b. (a -> b) -> a -> b $ forall w (m :: * -> *). MonadLogger w m => w -> m () Logger.log ((a kind, t module_), forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst [(Symbol, call)] dups) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ (t module_,) forall a b. (a -> b) -> a -> b $ Derive.CallMap { call_map :: Map Symbol call call_map = Map Symbol call cmap , call_patterns :: [PatternCall call] call_patterns = [PatternCall call] patterns } partition :: [Entry b] -> ([(Symbol, b)], [PatternCall b]) partition = forall a b. [Either a b] -> ([a], [b]) Either.partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall {b}. Entry b -> Either (Symbol, b) (PatternCall b) partition1 partition1 :: Entry b -> Either (Symbol, b) (PatternCall b) partition1 (Single Symbol sym b call) = forall a b. a -> Either a b Left (Symbol sym, b call) partition1 (Pattern PatternCall b pattern) = forall a b. b -> Either a b Right PatternCall b pattern compile_log :: Log.LogMonad m => Library -> m Derive.Builtins compile_log :: forall (m :: * -> *). LogMonad m => Library -> m Builtins compile_log Library lib = do let (Builtins builtins, [Shadowed] shadows) = Library -> (Builtins, [Shadowed]) compile Library lib forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [Shadowed] shadows forall a b. (a -> b) -> a -> b $ \((Text call_type, Module _module), [Symbol] calls) -> forall (m :: * -> *). (Stack, LogMonad m) => Text -> m () Log.warn forall a b. (a -> b) -> a -> b $ Text call_type forall a. Semigroup a => a -> a -> a <> Text " shadowed: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty [Symbol] calls forall (m :: * -> *) a. Monad m => a -> m a return Builtins builtins