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

{-# LANGUAGE StrictData #-}
-- | 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 (
    Type(..)
    , NumType(..)
    , NumValue(..)
    , general_type_of, specific_type_of
) where
import qualified Data.List as List
import qualified Data.Text as Text

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

import           Global


data Type =
    -- | This is the \"any\" type.
    TVal
    | TSignal NumType NumValue
    | TPSignal
    | 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
    -- | 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
    | TCFunction
    | TPFunction
    | 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
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
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
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)

-- | Get the intersection of the types.  If there's no intersection, it winds
-- up at TVal.  This is for 'infer_type_of'
instance Semigroup Type where
    TSignal NumType
t1 NumValue
vt1 <> :: Type -> Type -> Type
<> TSignal NumType
t2 NumValue
vt2 = NumType -> NumValue -> Type
TSignal (NumType
t1forall a. Semigroup a => a -> a -> a
<>NumType
t2) (NumValue
vt1forall a. Semigroup a => a -> a -> a
<>NumValue
vt2)
    TMaybe Type
t1 <> TMaybe Type
t2 = Type -> Type
TMaybe (Type
t1 forall a. Semigroup a => a -> a -> a
<> Type
t2)
    TEither Type
t1 Type
u1 <> TEither Type
t2 Type
u2 = Type -> Type -> Type
TEither (Type
t1forall a. Semigroup a => a -> a -> a
<>Type
t2) (Type
u1forall a. Semigroup a => a -> a -> a
<>Type
u2)
    TPair Type
t1 Type
u1 <> TPair Type
t2 Type
u2 = Type -> Type -> Type
TPair (Type
t1forall a. Semigroup a => a -> a -> a
<>Type
t2) (Type
u1forall a. Semigroup a => a -> a -> a
<>Type
u2)
    TList Type
t1 <> TList Type
t2 = Type -> Type
TList (Type
t1forall a. Semigroup a => a -> a -> a
<>Type
t2)
    Type
t1 <> Type
t2
        | Type
t1 forall a. Eq a => a -> a -> Bool
== Type
t2 = Type
t1
        | Bool
otherwise = Type
TVal

-- | Some of these are subtypes of others (TTranspose includes
-- TDefaultDiatonic), but since they're just documentation, it shouldn't
-- matter.
data NumType = TUntyped | TInt
    | TTranspose | TDefaultDiatonic | TDefaultChromatic | TNoteNumber
    | TTime | TDefaultReal | TDefaultScore | TRealTime | TScoreTime
    deriving (NumType -> NumType -> Bool
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
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
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)

instance Semigroup NumType where
    NumType
t1 <> :: NumType -> NumType -> NumType
<> NumType
t2
        | NumType
t1 forall a. Eq a => a -> a -> Bool
== NumType
t2 = NumType
t1
        | Bool
otherwise = NumType
TUntyped

-- | Numeric subtypes.
data NumValue =
    TAny
    -- | >=0
    | TNonNegative
    -- | >0
    | TPositive
    -- | 0 <= a <= 1
    | TNormalized
    -- | -1 <= a <= 1
    | TNormalizedBipolar
    deriving (NumValue -> NumValue -> Bool
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
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
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)

instance Semigroup NumValue where
    NumValue
t1 <> :: NumValue -> NumValue -> NumValue
<> NumValue
t2
        | NumValue
t1 forall a. Eq a => a -> a -> Bool
== NumValue
t2 = NumValue
t1
        | Bool
otherwise = NumValue
TAny

instance Pretty Type where
    pretty :: Type -> Text
pretty = \case
        TMaybe Type
typ -> Text
"Maybe " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Type
typ
        TEither Type
a Type
b -> forall a. Pretty a => a -> Text
pretty Type
a forall a. Semigroup a => a -> a -> a
<> Text
" or " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Type
b
        TPair Type
a Type
b -> Text
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Type
a forall a. Semigroup a => a -> a -> a
<> Text
", " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Type
b forall a. Semigroup a => a -> a -> a
<> Text
")"
        TSignal NumType
typ NumValue
vtype -> Text -> Text -> Text
append_parens Text
"Signal" forall a b. (a -> b) -> a -> b
$
            forall a. Textlike a => a -> a -> a -> a
Texts.join2 Text
", " (forall a. Pretty a => a -> Text
pretty NumType
typ) (forall a. Pretty a => a -> Text
pretty NumValue
vtype)
        TStr Maybe [Text]
enums -> Text -> Text -> Text
append_parens Text
"Str" forall a b. (a -> b) -> a -> b
$ 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.
        Type
TControl -> Text -> Text -> Text
append_parens Text
"Control" Text
Id.symbol_description
        Type
TPControl -> Text -> Text -> Text
append_parens Text
"PControl" (Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
Id.symbol_description)
        TList Type
typ -> Text
"list of " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Type
typ
        TOther Text
text -> Text
text
        Type
TNotGiven -> Text
"_"
        TDeriver Text
name -> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" deriver"
        Type
typ -> Int -> Text -> Text
Text.drop Int
1 (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 forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> Text
desc forall a. Semigroup a => a -> a -> a
<> Text
")"

instance Pretty NumType where
    pretty :: NumType -> Text
pretty = \case
        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 = \case
        NumValue
TAny -> Text
""
        NumValue
TNonNegative -> Text
">=0"
        NumValue
TPositive -> Text
">0"
        NumValue
TNormalized -> Text
"0 <= x <= 1"
        NumValue
TNormalizedBipolar -> Text
"-1 <= x <= 1"

-- | Infer the most specific type possible, looking at the value inside.  This
-- is for documentation (e.g. type error messages) for values.
specific_type_of :: Val -> Type
specific_type_of :: Val -> Type
specific_type_of = Bool -> Val -> Type
infer_type_of Bool
True

-- | Infer a general type.  This is also for type errors, but for env type
-- check errors, which use 'DeriveT.types_equal', which doesn't check the
-- value.
general_type_of :: Val -> Type
general_type_of :: Val -> Type
general_type_of = Bool -> Val -> Type
infer_type_of Bool
False

infer_type_of :: Bool -> Val -> Type
infer_type_of :: Bool -> Val -> Type
infer_type_of Bool
specific = \case
    VSignal (ScoreT.Typed Type
typ Control
sig) -> NumType -> NumValue -> Type
TSignal (Type -> NumType
to_num_type Type
typ) forall a b. (a -> b) -> a -> b
$
        if Bool -> Bool
not Bool
specific then NumValue
TAny
        else case forall {k} (kind :: k). Signal kind -> Maybe Y
Signal.constant_val Control
sig of
            Maybe Y
Nothing -> NumValue
TAny
            Just Y
n
                | Y
n forall a. Ord a => a -> a -> Bool
> Y
0 -> NumValue
TPositive
                | Y
n forall a. Ord a => a -> a -> Bool
>= Y
0 -> NumValue
TNonNegative
                | Bool
otherwise -> NumValue
TAny
    VPSignal {} -> Type
TPSignal
    VAttributes {} -> Type
TAttributes
    VControlRef {} -> Type
TControlRef
    VPControlRef {} -> Type
TPControlRef
    VPitch {} -> Type
TPitch
    VNotePitch {} -> Type
TNotePitch
    VStr {} -> Maybe [Text] -> Type
TStr forall a. Maybe a
Nothing
    VQuoted {} -> Type
TQuoted
    VCFunction {} -> Type
TCFunction
    VPFunction {} -> Type
TPFunction
    Val
VNotGiven -> Type
TNotGiven
    Val
VSeparator -> Type
TSeparator
    VList [] -> Type -> Type
TList Type
TVal
    -- Could use NonEmpty and sconcat, but too much bother.
    VList [Val]
vs -> Type -> Type
TList (forall a. (a -> a -> a) -> [a] -> a
List.foldl1' forall a. Semigroup a => a -> a -> a
(<>) (forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Val -> Type
infer_type_of Bool
specific) [Val]
vs))

to_num_type :: ScoreT.Type -> NumType
to_num_type :: Type -> NumType
to_num_type = \case
    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