    {-# OPTIONS -w #-}

    module Lambdabot.Plugin.Haskell.Free.Type where

    import Control.Monad
    import Lambdabot.Plugin.Haskell.Free.Parse
    import Data.List
    import Lambdabot.Plugin.Haskell.Free.Util
    import Prelude hiding ((<>))

    type TyVar = String
    type TyName = String

    data Type
        = TyForall TyVar Type
        | TyArr Type Type
        | TyTuple [Type]
        | TyCons TyName [Type]
        | TyVar TyVar
            deriving (Type -> Type -> Bool
    (Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Type -> Type -> Bool
    == :: Type -> Type -> Bool
    $c/= :: Type -> Type -> Bool
    /= :: Type -> Type -> Bool
    Eq, Int -> Type -> ShowS
    [Type] -> ShowS
    Type -> TyVar
    (Int -> Type -> ShowS)
    -> (Type -> TyVar) -> ([Type] -> ShowS) -> Show Type
    forall a.
    (Int -> a -> ShowS) -> (a -> TyVar) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Type -> ShowS
    showsPrec :: Int -> Type -> ShowS
    $cshow :: Type -> TyVar
    show :: Type -> TyVar
    $cshowList :: [Type] -> ShowS
    showList :: [Type] -> ShowS
    Show)

    precTYAPP, precARROW :: Int
    precTYAPP :: Int
    precTYAPP = Int
    11
    precARROW :: Int
    precARROW = Int
    10

    instance Pretty Type where
        prettyP :: Int -> Type -> Doc
    prettyP Int
    p (TyForall TyVar
    v Type
    t)
            = Bool -> Doc -> Doc
    prettyParen (Int
    p Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0) (
                TyVar -> Doc
    text TyVar
    "forall" Doc -> Doc -> Doc
    <+> TyVar -> Doc
    text TyVar
    v Doc -> Doc -> Doc
    <> TyVar -> Doc
    text TyVar
    "." Doc -> Doc -> Doc
    <+> Int -> Type -> Doc
    forall a. Pretty a => Int -> a -> Doc
    prettyP Int
    0 Type
    t
            )
        prettyP Int
    p (TyArr Type
    t1 Type
    t2)
            = Bool -> Doc -> Doc
    prettyParen (Int
    p Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    precARROW) (
                Int -> Type -> Doc
    forall a. Pretty a => Int -> a -> Doc
    prettyP (Int
    precARROWInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) Type
    t1 Doc -> Doc -> Doc
    <+> TyVar -> Doc
    text TyVar
    "->" Doc -> Doc -> Doc
    <+> Int -> Type -> Doc
    forall a. Pretty a => Int -> a -> Doc
    prettyP Int
    precARROW Type
    t2
            )
        prettyP Int
    _ (TyTuple [])
            = Doc -> Doc
    parens Doc
    empty
        prettyP Int
    _ (TyTuple (Type
    t:[Type]
    ts))
            = Doc -> Doc
    parens (Int -> Type -> Doc
    forall a. Pretty a => Int -> a -> Doc
    prettyP Int
    0 Type
    t Doc -> Doc -> Doc
    <> Int -> Doc -> [Type] -> Doc
    prettyTs Int
    0 (TyVar -> Doc
    text TyVar
    ",") [Type]
    ts)
        prettyP Int
    _ (TyCons TyVar
    "[]" [Type
    t])
            = Doc
    lbrack Doc -> Doc -> Doc
    <> Int -> Type -> Doc
    forall a. Pretty a => Int -> a -> Doc
    prettyP Int
    0 Type
    t Doc -> Doc -> Doc
    <> Doc
    rbrack
        prettyP Int
    p (TyCons TyVar
    cons [Type]
    ts)
            = Bool -> Doc -> Doc
    prettyParen (Int
    p Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    precTYAPP) (
                TyVar -> Doc
    text TyVar
    cons Doc -> Doc -> Doc
    <> Int -> Doc -> [Type] -> Doc
    prettyTs (Int
    precTYAPPInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) Doc
    empty [Type]
    ts
            )
        prettyP Int
    _ (TyVar TyVar
    v)
            = TyVar -> Doc
    text TyVar
    v

    prettyTs :: Int -> Doc -> [Type] -> Doc
    prettyTs :: Int -> Doc -> [Type] -> Doc
    prettyTs Int
    p Doc
    c [] = Doc
    empty
    prettyTs Int
    p Doc
    c (Type
    t:[Type]
    ts) = Doc
    c Doc -> Doc -> Doc
    <+> Int -> Type -> Doc
    forall a. Pretty a => Int -> a -> Doc
    prettyP Int
    p Type
    t Doc -> Doc -> Doc
    <> Int -> Doc -> [Type] -> Doc
    prettyTs Int
    p Doc
    c [Type]
    ts

    parseType :: ParseS Type
    parseType :: ParseS Type
    parseType
        = ParseS Type
    parseType' ParseS Type -> (Type -> ParseS Type) -> ParseS Type
    forall a b. ParseS a -> (a -> ParseS b) -> ParseS b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> ParseS Type) -> (Type -> Type) -> Type -> ParseS Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> Type
    normaliseType

    parseType' :: ParseS Type
    parseType' :: ParseS Type
    parseType'
        = do
            t <- ParseS (Maybe Token)
    peekToken
            case t of
                Just Token
    IdForall -> ParseS (Maybe Token)
    getToken ParseS (Maybe Token) -> ParseS Type -> ParseS Type
    forall a b. ParseS a -> ParseS b -> ParseS b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> ParseS Type
    parseForall
                Maybe Token
    _             -> ParseS Type
    parseArrType
        where
            parseForall :: ParseS Type
    parseForall
                = do
                    t <- ParseS (Maybe Token)
    getToken
                    case t of
                        Just (QVarId TyVar
    v)
                            -> ParseS Type
    parseForall ParseS Type -> (Type -> ParseS Type) -> ParseS Type
    forall a b. ParseS a -> (a -> ParseS b) -> ParseS b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    t -> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyVar -> Type -> Type
    TyForall TyVar
    v Type
    t)
                        Just (QVarSym TyVar
    ".")
                            -> ParseS Type
    parseType'
                        Maybe Token
    _   -> TyVar -> ParseS Type
    forall a. TyVar -> ParseS a
    forall (m :: * -> *) a. MonadFail m => TyVar -> m a
    fail TyVar
    "Expected variable or '.'"

            parseArrType :: ParseS Type
    parseArrType
                = do
                    t1 <- ParseS Type
    parseBType
                    t <- peekToken
                    case t of
                        Just Token
    OpArrow
                            -> ParseS (Maybe Token)
    getToken ParseS (Maybe Token) -> ParseS Type -> ParseS Type
    forall a b. ParseS a -> ParseS b -> ParseS b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> ParseS Type
    parseType' ParseS Type -> (Type -> ParseS Type) -> ParseS Type
    forall a b. ParseS a -> (a -> ParseS b) -> ParseS b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    t2 ->
                                Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Type -> Type
    TyArr Type
    t1 Type
    t2)
                        Maybe Token
    _   -> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    t1

            parseBType :: ParseS Type
    parseBType
                = do
                    t1 <- ParseS Type
    parseAType
                    case t1 of
                        TyCons TyVar
    c [Type]
    ts
                            -> do
                                ts' <- ParseS [Type]
    parseBTypes
                                return (TyCons c (ts++ts'))
                        Type
    _   -> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    t1

            parseBTypes :: ParseS [Type]
    parseBTypes
                = (ParseS Type
    parseBType ParseS Type -> (Type -> ParseS [Type]) -> ParseS [Type]
    forall a b. ParseS a -> (a -> ParseS b) -> ParseS b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    t -> ParseS [Type]
    parseBTypes ParseS [Type] -> ([Type] -> ParseS [Type]) -> ParseS [Type]
    forall a b. ParseS a -> (a -> ParseS b) -> ParseS b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \[Type]
    ts -> [Type] -> ParseS [Type]
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type
    tType -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    :[Type]
    ts))
                    ParseS [Type] -> ParseS [Type] -> ParseS [Type]
    forall a. ParseS a -> ParseS a -> ParseS a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus` [Type] -> ParseS [Type]
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

            parseAType :: ParseS Type
    parseAType
                = ParseS Type
    parseQTyCon ParseS Type -> ParseS Type -> ParseS Type
    forall a. ParseS a -> ParseS a -> ParseS a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus` ParseS Type
    parseOtherAType

            parseQTyCon :: ParseS Type
    parseQTyCon
                = do
                    t <- ParseS (Maybe Token)
    getToken
                    case t of
                        Just Token
    OpenParen
                            -> do
                                t <- ParseS (Maybe Token)
    getToken
                                case t of
                                    Just Token
    CloseParen
                                        -> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyVar -> [Type] -> Type
    TyCons TyVar
    "()" [])
                                    Just Token
    OpArrow
                                        -> Token -> ParseS ()
    match Token
    CloseParen
                                            ParseS () -> ParseS Type -> ParseS Type
    forall a b. ParseS a -> ParseS b -> ParseS b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyVar -> [Type] -> Type
    TyCons TyVar
    "->" [])
                                    Just Token
    Comma
                                        -> Int -> ParseS Type
    parseQTyConTuple Int
    1
                                    Maybe Token
    _   -> TyVar -> ParseS Type
    forall a. TyVar -> ParseS a
    forall (m :: * -> *) a. MonadFail m => TyVar -> m a
    fail TyVar
    "Badly formed type constructor"
                        Just Token
    OpenBracket
                            -> Token -> ParseS ()
    match Token
    CloseBracket ParseS () -> ParseS Type -> ParseS Type
    forall a b. ParseS a -> ParseS b -> ParseS b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyVar -> [Type] -> Type
    TyCons TyVar
    "[]" [])
                        Just (QConId TyVar
    v)
                            -> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyVar -> [Type] -> Type
    TyCons TyVar
    v [])
                        Maybe Token
    _   -> TyVar -> ParseS Type
    forall a. TyVar -> ParseS a
    forall (m :: * -> *) a. MonadFail m => TyVar -> m a
    fail TyVar
    "Badly formed type constructor"

            parseQTyConTuple :: Int -> ParseS Type
            parseQTyConTuple :: Int -> ParseS Type
    parseQTyConTuple Int
    i
                = do
                    t <- ParseS (Maybe Token)
    getToken
                    case t of
                        Just Token
    Comma
                            -> Int -> ParseS Type
    parseQTyConTuple (Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1)
                        Just Token
    CloseParen
                            -> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyVar -> [Type] -> Type
    TyCons (TyVar
    "(" TyVar -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> ShowS
    forall a. Int -> [a] -> [a]
    take Int
    i (Char -> TyVar
    forall a. a -> [a]
    repeat Char
    ',') TyVar -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ TyVar
    ")") [])
                        Maybe Token
    _   -> TyVar -> ParseS Type
    forall a. TyVar -> ParseS a
    forall (m :: * -> *) a. MonadFail m => TyVar -> m a
    fail TyVar
    "Badly formed type constructor"

            parseOtherAType :: ParseS Type
    parseOtherAType
                = do
                    t1 <- ParseS (Maybe Token)
    getToken
                    case t1 of
                        Just Token
    OpenParen
                            -> do
                                t <- ParseS Type
    parseType'
                                parseTuple [t]
                        Just Token
    OpenBracket
                            -> ParseS Type
    parseType' ParseS Type -> (Type -> ParseS Type) -> ParseS Type
    forall a b. ParseS a -> (a -> ParseS b) -> ParseS b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Type
    t -> Token -> ParseS ()
    match Token
    CloseBracket
                                            ParseS () -> ParseS Type -> ParseS Type
    forall a b. ParseS a -> ParseS b -> ParseS b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyVar -> [Type] -> Type
    TyCons TyVar
    "[]" [Type
    t])
                        Just (QVarId TyVar
    v)
                            -> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TyVar -> Type
    TyVar TyVar
    v)
                        Maybe Token
    _   -> TyVar -> ParseS Type
    forall a. TyVar -> ParseS a
    forall (m :: * -> *) a. MonadFail m => TyVar -> m a
    fail TyVar
    "Badly formed type"

            parseTuple :: [Type] -> ParseS Type
    parseTuple [Type]
    ts
                = do
                    t1 <- ParseS (Maybe Token)
    getToken
                    case t1 of
                        Just Token
    CloseParen
                            -> case [Type]
    ts of
                                    [Type
    t] -> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    t
                                    [Type]
    _   -> Type -> ParseS Type
    forall a. a -> ParseS a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Type] -> Type
    TyTuple ([Type] -> [Type]
    forall a. [a] -> [a]
    reverse [Type]
    ts))
                        Just Token
    Comma
                            -> do
                                t <- ParseS Type
    parseType'
                                parseTuple (t:ts)

    normaliseType :: Type -> Type
    normaliseType :: Type -> Type
    normaliseType Type
    t
        = let ([TyVar]
    fvs,Type
    nt) = Type -> ([TyVar], Type)
    normaliseType' Type
    t
          in (TyVar -> Type -> Type) -> Type -> [TyVar] -> Type
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr TyVar -> Type -> Type
    TyForall Type
    nt ([TyVar] -> [TyVar]
    forall a. Eq a => [a] -> [a]
    nub [TyVar]
    fvs)
        where
            normaliseType' :: Type -> ([TyVar], Type)
    normaliseType' t :: Type
    t@(TyVar TyVar
    v)
                = ([TyVar
    v],Type
    t)
            normaliseType' (TyForall TyVar
    v Type
    t')
                = let ([TyVar]
    fvs,Type
    t) = Type -> ([TyVar], Type)
    normaliseType' Type
    t'
                  in ((TyVar -> Bool) -> [TyVar] -> [TyVar]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (TyVar -> TyVar -> Bool
    forall a. Eq a => a -> a -> Bool
    /=TyVar
    v) [TyVar]
    fvs, TyVar -> Type -> Type
    TyForall TyVar
    v Type
    t)
            normaliseType' (TyArr Type
    t1 Type
    t2)
                = let
                    ([TyVar]
    fvs1,Type
    t1') = Type -> ([TyVar], Type)
    normaliseType' Type
    t1
                    ([TyVar]
    fvs2,Type
    t2') = Type -> ([TyVar], Type)
    normaliseType' Type
    t2
                  in
                    ([TyVar]
    fvs1[TyVar] -> [TyVar] -> [TyVar]
    forall a. [a] -> [a] -> [a]
    ++[TyVar]
    fvs2, Type -> Type -> Type
    TyArr Type
    t1' Type
    t2')
            normaliseType' (TyTuple [Type]
    ts)
                = let
                    fvsts :: [([TyVar], Type)]
    fvsts = (Type -> ([TyVar], Type)) -> [Type] -> [([TyVar], Type)]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> ([TyVar], Type)
    normaliseType' [Type]
    ts
                    fvs :: [TyVar]
    fvs = [[TyVar]] -> [TyVar]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ((([TyVar], Type) -> [TyVar]) -> [([TyVar], Type)] -> [[TyVar]]
    forall a b. (a -> b) -> [a] -> [b]
    map ([TyVar], Type) -> [TyVar]
    forall a b. (a, b) -> a
    fst [([TyVar], Type)]
    fvsts)
                    ts' :: [Type]
    ts' = (([TyVar], Type) -> Type) -> [([TyVar], Type)] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map ([TyVar], Type) -> Type
    forall a b. (a, b) -> b
    snd [([TyVar], Type)]
    fvsts
                  in ([TyVar]
    fvs, [Type] -> Type
    TyTuple [Type]
    ts')
            normaliseType' (TyCons TyVar
    c [Type]
    ts)
                = let
                    fvsts :: [([TyVar], Type)]
    fvsts = (Type -> ([TyVar], Type)) -> [Type] -> [([TyVar], Type)]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> ([TyVar], Type)
    normaliseType' [Type]
    ts
                    fvs :: [TyVar]
    fvs = [[TyVar]] -> [TyVar]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ((([TyVar], Type) -> [TyVar]) -> [([TyVar], Type)] -> [[TyVar]]
    forall a b. (a -> b) -> [a] -> [b]
    map ([TyVar], Type) -> [TyVar]
    forall a b. (a, b) -> a
    fst [([TyVar], Type)]
    fvsts)
                    ts' :: [Type]
    ts' = (([TyVar], Type) -> Type) -> [([TyVar], Type)] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map ([TyVar], Type) -> Type
    forall a b. (a, b) -> b
    snd [([TyVar], Type)]
    fvsts
                  in case TyVar
    c of
                        TyVar
    "->" -> case [Type]
    ts' of
                            [Type
    t1,Type
    t2] -> ([TyVar]
    fvs, Type -> Type -> Type
    TyArr Type
    t1 Type
    t2)
                            [Type]
    _ -> TyVar -> ([TyVar], Type)
    forall a. HasCallStack => TyVar -> a
    error TyVar
    "Arrow type should have 2 arguments"
                        TyVar
    _ -> case TyVar -> Maybe Int
    forall {a}. Num a => TyVar -> Maybe a
    checkTuple TyVar
    c of
                            Just Int
    i
                                -> if Int
    i Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    ts'
                                    then ([TyVar]
    fvs, [Type] -> Type
    TyTuple [Type]
    ts')
                                    else TyVar -> ([TyVar], Type)
    forall a. HasCallStack => TyVar -> a
    error TyVar
    "Tuple type has the wrong number of arguments"
                            Maybe Int
    Nothing
                                -> ([TyVar]
    fvs, TyVar -> [Type] -> Type
    TyCons TyVar
    c [Type]
    ts')

            checkTuple :: TyVar -> Maybe a
    checkTuple (Char
    '(':Char
    ')':TyVar
    cs)
                = a -> Maybe a
    forall a. a -> Maybe a
    Just a
    0
            checkTuple (Char
    '(':TyVar
    cs)
                = a -> TyVar -> Maybe a
    forall {t}. Num t => t -> TyVar -> Maybe t
    checkTuple' a
    1 TyVar
    cs
            checkTuple TyVar
    _
                = Maybe a
    forall a. Maybe a
    Nothing

            checkTuple' :: t -> TyVar -> Maybe t
    checkTuple' t
    k TyVar
    ")"
                = t -> Maybe t
    forall a. a -> Maybe a
    Just t
    k
            checkTuple' t
    k (Char
    ',':TyVar
    cs)
                = t -> TyVar -> Maybe t
    checkTuple' (t
    kt -> t -> t
    forall a. Num a => a -> a -> a
    +t
    1) TyVar
    cs
            checkTuple' t
    _ TyVar
    _
                = Maybe t
    forall a. Maybe a
    Nothing

    readType :: String -> Type
    readType :: TyVar -> Type
    readType TyVar
    s
        = case ParseS Type -> [Token] -> ParseResult Type
    forall a. ParseS a -> [Token] -> ParseResult a
    parse ParseS Type
    parseType (TyVar -> [Token]
    lexer TyVar
    s) of
            ParseSuccess Type
    t [] -> Type
    t
            ParseSuccess Type
    t [Token]
    _  -> TyVar -> Type
    forall a. HasCallStack => TyVar -> a
    error TyVar
    "Extra stuff at end of type"
            ParseError TyVar
    msg    -> TyVar -> Type
    forall a. HasCallStack => TyVar -> a
    error TyVar
    msg

    -- vim: ts=4:sts=4:expandtab:ai