-- 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