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

-- | Type descriptions of the 'Val'.
--
-- This is in its own module so "Derive.Deriver.Monad" can import it without
-- importing "Derive.Typecheck".
module Derive.ValType where
import qualified Data.Text as Text

import qualified Util.Texts as Texts
import           Derive.DeriveT (Val(..))
import qualified Derive.ScoreT as ScoreT
import qualified Ui.Id as Id

import           Global


data Type =
    TNum NumType NumValue
    | TAttributes | TControlRef | TPControlRef | TPitch | TNotePitch
    -- | Text string, with enum values if it's an enum.
    | TStr (Maybe [Text]) | TControl | TPControl
    | TNotGiven | TSeparator | TMaybe Type | TEither Type Type
    -- | This is the \"any\" type.
    | TVal
    -- | Two types in sequence.  This has no corresponding Typecheck instance
    -- since it doesn't correspond to a single Val, but is used by "Derive.Sig"
    -- for documentation.
    | TPair Type Type
    -- | A 'VQuoted'.  This has no Typecheck instance so it should never show
    -- up as a call argument.
    | TQuoted
    | TControlFunction
    | TList !Type
    | TDeriver !Text
    -- | Typecheck instances that don't correspond directly to a Val type
    -- get this, as a plain description.
    | TOther !Text
    deriving (Type -> Type -> Bool
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq, Eq Type
Eq Type
-> (Type -> Type -> Ordering)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Type)
-> (Type -> Type -> Type)
-> Ord Type
Type -> Type -> Bool
Type -> Type -> Ordering
Type -> Type -> Type
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Type -> Type -> Type
$cmin :: Type -> Type -> Type
max :: Type -> Type -> Type
$cmax :: Type -> Type -> Type
>= :: Type -> Type -> Bool
$c>= :: Type -> Type -> Bool
> :: Type -> Type -> Bool
$c> :: Type -> Type -> Bool
<= :: Type -> Type -> Bool
$c<= :: Type -> Type -> Bool
< :: Type -> Type -> Bool
$c< :: Type -> Type -> Bool
compare :: Type -> Type -> Ordering
$ccompare :: Type -> Type -> Ordering
Ord, Int -> Type -> ShowS
[Type] -> ShowS
Type -> String
(Int -> Type -> ShowS)
-> (Type -> String) -> ([Type] -> ShowS) -> Show Type
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Type] -> ShowS
$cshowList :: [Type] -> ShowS
show :: Type -> String
$cshow :: Type -> String
showsPrec :: Int -> Type -> ShowS
$cshowsPrec :: Int -> Type -> ShowS
Show)

-- | These are kind of muddled.  This is because they were originally just
-- documentation, so the more specific the better, but are also used for
-- typechecking in 'Derive.Env.put_val', so the subtype relations need to be
-- respected.  But since some are just documentation (e.g. TDefaultReal), they
-- should never show up on the LHS of a put_val typecheck.
data NumType = TUntyped | TInt
    | TTranspose | TDefaultDiatonic | TDefaultChromatic | TNoteNumber
    | TTime | TDefaultReal | TDefaultScore | TRealTime | TScoreTime
    deriving (NumType -> NumType -> Bool
(NumType -> NumType -> Bool)
-> (NumType -> NumType -> Bool) -> Eq NumType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NumType -> NumType -> Bool
$c/= :: NumType -> NumType -> Bool
== :: NumType -> NumType -> Bool
$c== :: NumType -> NumType -> Bool
Eq, Eq NumType
Eq NumType
-> (NumType -> NumType -> Ordering)
-> (NumType -> NumType -> Bool)
-> (NumType -> NumType -> Bool)
-> (NumType -> NumType -> Bool)
-> (NumType -> NumType -> Bool)
-> (NumType -> NumType -> NumType)
-> (NumType -> NumType -> NumType)
-> Ord NumType
NumType -> NumType -> Bool
NumType -> NumType -> Ordering
NumType -> NumType -> NumType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NumType -> NumType -> NumType
$cmin :: NumType -> NumType -> NumType
max :: NumType -> NumType -> NumType
$cmax :: NumType -> NumType -> NumType
>= :: NumType -> NumType -> Bool
$c>= :: NumType -> NumType -> Bool
> :: NumType -> NumType -> Bool
$c> :: NumType -> NumType -> Bool
<= :: NumType -> NumType -> Bool
$c<= :: NumType -> NumType -> Bool
< :: NumType -> NumType -> Bool
$c< :: NumType -> NumType -> Bool
compare :: NumType -> NumType -> Ordering
$ccompare :: NumType -> NumType -> Ordering
Ord, Int -> NumType -> ShowS
[NumType] -> ShowS
NumType -> String
(Int -> NumType -> ShowS)
-> (NumType -> String) -> ([NumType] -> ShowS) -> Show NumType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NumType] -> ShowS
$cshowList :: [NumType] -> ShowS
show :: NumType -> String
$cshow :: NumType -> String
showsPrec :: Int -> NumType -> ShowS
$cshowsPrec :: Int -> NumType -> ShowS
Show)

-- | Numeric subtypes.
data NumValue = TAny
    -- | >=0
    | TNonNegative
    -- | >0
    | TPositive
    -- | 0 <= a <= 1
    | TNormalized
    -- | -1 <= a <= 1
    | TNormalizedBipolar
    deriving (NumValue -> NumValue -> Bool
(NumValue -> NumValue -> Bool)
-> (NumValue -> NumValue -> Bool) -> Eq NumValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NumValue -> NumValue -> Bool
$c/= :: NumValue -> NumValue -> Bool
== :: NumValue -> NumValue -> Bool
$c== :: NumValue -> NumValue -> Bool
Eq, Eq NumValue
Eq NumValue
-> (NumValue -> NumValue -> Ordering)
-> (NumValue -> NumValue -> Bool)
-> (NumValue -> NumValue -> Bool)
-> (NumValue -> NumValue -> Bool)
-> (NumValue -> NumValue -> Bool)
-> (NumValue -> NumValue -> NumValue)
-> (NumValue -> NumValue -> NumValue)
-> Ord NumValue
NumValue -> NumValue -> Bool
NumValue -> NumValue -> Ordering
NumValue -> NumValue -> NumValue
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NumValue -> NumValue -> NumValue
$cmin :: NumValue -> NumValue -> NumValue
max :: NumValue -> NumValue -> NumValue
$cmax :: NumValue -> NumValue -> NumValue
>= :: NumValue -> NumValue -> Bool
$c>= :: NumValue -> NumValue -> Bool
> :: NumValue -> NumValue -> Bool
$c> :: NumValue -> NumValue -> Bool
<= :: NumValue -> NumValue -> Bool
$c<= :: NumValue -> NumValue -> Bool
< :: NumValue -> NumValue -> Bool
$c< :: NumValue -> NumValue -> Bool
compare :: NumValue -> NumValue -> Ordering
$ccompare :: NumValue -> NumValue -> Ordering
Ord, Int -> NumValue -> ShowS
[NumValue] -> ShowS
NumValue -> String
(Int -> NumValue -> ShowS)
-> (NumValue -> String) -> ([NumValue] -> ShowS) -> Show NumValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NumValue] -> ShowS
$cshowList :: [NumValue] -> ShowS
show :: NumValue -> String
$cshow :: NumValue -> String
showsPrec :: Int -> NumValue -> ShowS
$cshowsPrec :: Int -> NumValue -> ShowS
Show)

-- | This typechecking already exists in the Typecheck instances, but all it
-- can do is go from a Val to a @Typecheck a => Maybe a@.  So I can't reuse it
-- to check a type against a type, so it has to be duplicated, similar to how
-- 'type_of' can't reuse 'to_type'.
--
-- The result is I have redundant functions like 'subtypes_of' and 'type_of'
-- and 'to_num_type', and a mistake or inconsistency with 'to_type' or 'to_val'
-- will cause typechecking to fail in some subtle case.  Fortunately there are
-- relatively few types and hopefully won't be many more, and it only affects
-- 'Derive.Env.put_val'.  It could all do with a cleanup.  I'm sure there's a
-- right way to do this sort of thing.
types_match :: Type -> Type -> Bool
types_match :: Type -> Type -> Bool
types_match Type
t1 Type
t2 = case (Type
t1, Type
t2) of
    (TNum NumType
n1 NumValue
v1, TNum NumType
n2 NumValue
v2) -> NumType -> NumType -> Bool
num_types_match NumType
n1 NumType
n2 Bool -> Bool -> Bool
&& NumValue -> NumValue -> Bool
forall {a}. Ord a => a -> a -> Bool
num_vals_match NumValue
v1 NumValue
v2
    (TMaybe Type
t1, TMaybe Type
t2) -> Type -> Type -> Bool
types_match Type
t1 Type
t2
    (TPair Type
t1 Type
t2, TPair Type
u1 Type
u2) -> Type -> Type -> Bool
types_match Type
t1 Type
u1 Bool -> Bool -> Bool
&& Type -> Type -> Bool
types_match Type
t2 Type
u2
    (TEither Type
t1 Type
u1, TEither Type
t2 Type
u2) -> Type -> Type -> Bool
types_match Type
t1 Type
t2 Bool -> Bool -> Bool
&& Type -> Type -> Bool
types_match Type
u1 Type
u2
    (TList Type
t1, TList Type
t2) -> Type -> Type -> Bool
types_match Type
t1 Type
t2
    (Type
t1, Type
t2) -> Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t2
    where
    num_types_match :: NumType -> NumType -> Bool
num_types_match NumType
n1 NumType
n2 = NumType
n2 NumType -> [NumType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NumType -> [NumType]
subtypes_of NumType
n1
    num_vals_match :: a -> a -> Bool
num_vals_match a
v1 a
v2 = a
v1 a -> a -> Bool
forall {a}. Ord a => a -> a -> Bool
<= a
v2

-- | Nothing if the type of the rhs matches the lhs, otherwise the expected
-- type.
val_types_match :: Val -> Val -> Maybe Type
val_types_match :: Val -> Val -> Maybe Type
val_types_match Val
lhs Val
rhs
    | Type -> Type -> Bool
types_match Type
expected (Val -> Type
type_of Val
rhs) = Maybe Type
forall a. Maybe a
Nothing
    | Bool
otherwise = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
expected
    where expected :: Type
expected = Bool -> Val -> Type
infer_type_of Bool
False Val
lhs

subtypes_of :: NumType -> [NumType]
subtypes_of :: NumType -> [NumType]
subtypes_of NumType
n
    | NumType
n NumType -> [NumType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NumType
TTime, NumType
TDefaultReal, NumType
TDefaultScore] =
        [NumType
TTime, NumType
TDefaultReal, NumType
TDefaultScore, NumType
TRealTime, NumType
TScoreTime]
    | NumType
n NumType -> [NumType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [NumType]
transpose = [NumType]
transpose
    | Bool
otherwise = [NumType
n]
    where
    transpose :: [NumType]
transpose = [NumType
TTranspose, NumType
TDefaultDiatonic, NumType
TDefaultChromatic, NumType
TNoteNumber]

instance Pretty Type where
    pretty :: Type -> Text
pretty (TMaybe Type
typ) = Text
"Maybe " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
typ
    pretty (TEither Type
a Type
b) = Type -> Text
forall a. Pretty a => a -> Text
pretty Type
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" or " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
b
    pretty (TPair Type
a Type
b) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    pretty (TNum NumType
typ NumValue
val) = Text -> Text -> Text
append_parens Text
"Num" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
        Text -> Text -> Text -> Text
forall a. Textlike a => a -> a -> a -> a
Texts.join2 Text
", " (NumType -> Text
forall a. Pretty a => a -> Text
pretty NumType
typ) (NumValue -> Text
forall a. Pretty a => a -> Text
pretty NumValue
val)
    pretty (TStr Maybe [Text]
enums) = Text -> Text -> Text
append_parens Text
"Str" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> ([Text] -> Text) -> Maybe [Text] -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" [Text] -> Text
Text.unwords Maybe [Text]
enums
    -- There is no corresponding Val type for these, so I might as well be
    -- clear about what they mean.
    pretty Type
TControl = Text -> Text -> Text
append_parens Text
"Control" Text
Id.symbol_description
    pretty Type
TPControl = Text -> Text -> Text
append_parens Text
"PControl" (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
Id.symbol_description)
    pretty (TList Type
typ) = Text
"list of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
typ
    pretty (TOther Text
text) = Text
text
    pretty Type
TNotGiven = Text
"_"
    pretty (TDeriver Text
name) = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" deriver"
    pretty Type
typ = Int -> Text -> Text
Text.drop Int
1 (Type -> Text
forall a. Show a => a -> Text
showt Type
typ)

append_parens :: Text -> Text -> Text
append_parens :: Text -> Text -> Text
append_parens Text
name Text
desc
    | Text -> Bool
Text.null Text
desc = Text
name
    | Bool
otherwise = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

instance Pretty NumType where
    pretty :: NumType -> Text
pretty NumType
t = case NumType
t of
        NumType
TUntyped -> Text
""
        NumType
TInt -> Text
"integral"
        NumType
TTranspose -> Text
"Transposition"
        NumType
TDefaultDiatonic -> Text
"Transposition, default diatonic"
        NumType
TDefaultChromatic -> Text
"Transposition, default chromatic"
        NumType
TTime -> Text
"Time"
        NumType
TDefaultReal -> Text
"Time, default real"
        NumType
TDefaultScore -> Text
"Time, default score"
        NumType
TRealTime -> Text
"RealTime"
        NumType
TScoreTime -> Text
"ScoreTime"
        NumType
TNoteNumber -> Text
"NN"

instance Pretty NumValue where
    pretty :: NumValue -> Text
pretty NumValue
t = case NumValue
t of
        NumValue
TAny -> Text
""
        NumValue
TNonNegative -> Text
">=0"
        NumValue
TPositive -> Text
">0"
        NumValue
TNormalized -> Text
"0 <= x <= 1"
        NumValue
TNormalizedBipolar -> Text
"-1 <= x <= 1"

type_of :: Val -> Type
type_of :: Val -> Type
type_of = Bool -> Val -> Type
infer_type_of Bool
True

infer_type_of :: Bool -- ^ If True, infer the most specific type possible.
    -- Otherwise, infer a general type.  This is because if
    -- 'Derive.Env.put_val' gets a 1 it doesn't mean it's intended to be a
    -- TPositive.
    -> Val -> Type
infer_type_of :: Bool -> Val -> Type
infer_type_of Bool
specific Val
val = case Val
val of
    VNum (ScoreT.Typed Type
typ Y
val) -> NumType -> NumValue -> Type
TNum (Type -> NumType
to_num_type Type
typ) (NumValue -> Type) -> NumValue -> Type
forall a b. (a -> b) -> a -> b
$ if Bool
specific
        then (if Y
val Y -> Y -> Bool
forall {a}. Ord a => a -> a -> Bool
> Y
0 then NumValue
TPositive
            else if Y
val Y -> Y -> Bool
forall {a}. Ord a => a -> a -> Bool
>= Y
0 then NumValue
TNonNegative else NumValue
TAny)
        else NumValue
TAny
    VAttributes {} -> Type
TAttributes
    VControlRef {} -> Type
TControlRef
    VPControlRef {} -> Type
TPControlRef
    VPitch {} -> Type
TPitch
    VNotePitch {} -> Type
TNotePitch
    VStr {} -> Maybe [Text] -> Type
TStr Maybe [Text]
forall a. Maybe a
Nothing
    VQuoted {} -> Type
TQuoted
    VControlFunction {} -> Type
TControlFunction
    Val
VNotGiven -> Type
TNotGiven
    Val
VSeparator -> Type
TSeparator
    VList {} -> Type -> Type
TList Type
TVal

to_num_type :: ScoreT.Type -> NumType
to_num_type :: Type -> NumType
to_num_type Type
typ = case Type
typ of
    Type
ScoreT.Untyped -> NumType
TUntyped
    Type
ScoreT.Real -> NumType
TRealTime
    Type
ScoreT.Score -> NumType
TScoreTime
    Type
ScoreT.Diatonic -> NumType
TTranspose
    Type
ScoreT.Chromatic -> NumType
TTranspose
    Type
ScoreT.Nn -> NumType
TNoteNumber