/trunk/frege/compiler/TAlias.fr

-- enable UTF-8 ŤŤŤŤŤŤŤŤŤŤŤŤŤŤ•••••••••••••ťťťťťťťťťťťťŚŚŚŚŚŚŚŚ

{--

 * This is pass 4 of the compiler, implemented in 'pass'.

 * We must make sure that *type* definitions are not self-referential

 * directly or indirectly.

 -}

{-

 * $Author: Ingo.Wechsung@googlemail.com $

 * $Revision: 525 $

 * $Date: 2012-02-21 00:19:03 +0100 (Tue, 21 Feb 2012) $

 * $Id: TAlias.fr 525 2012-02-20 23:19:03Z Ingo.Wechsung@googlemail.com $

 -}



package frege.compiler.TAlias where



--- This is $Revision: 525 $

protected version = v "$Revision: 525 $" where

    v (m ~ #(\d+)#) | Just g <- m.group 1 = g.atoi

    v _ = 0





import frege.compiler.Data

import frege.compiler.Nice (msgdoc)

import frege.compiler.Utilities     as U()

import frege.compiler.Transdef      as T()

import Data.List as DL(partitioned)



--- post condition is true

post = do

    stio true



pass = do

    g <- getST

    let (adefs,other) = partitioned isTypDcl g.definitions

        adeps = map aliasdep adefs

        agrps = U.tsort adeps

        aflat = [ a | grp <- agrps, a <- grp ]

        sdefs = [ d | a <- aflat, d <- adefs, QName.base a == Definition.name d ]

        isTypDcl (TypDcl {pos}) = true

        isTypDcl _              = false

        aliasdep (TypDcl {pos, name, rho}) = (tn, filter (flip QName.our g) deps) where

                    tn = TName g.thisPack name

                    deps = collectRho rho []

        aliasdep x = error "no TypDcl"

        collectRho (RhoFun _ sig rho) acc = collectRho rho (collectSigma sig acc)

            where

                collectSigma (ForAll _ rho) acc = collectRho rho acc

        collectRho (RhoTau _ tau)     acc = collectTau tau acc

        collectTau (TVar _ _) acc = acc

        collectTau (Meta _)   acc = acc

        collectTau (TApp a b) acc = collectTau a (collectTau b acc)

        collectTau (TFun a b) acc = collectTau a (collectTau b acc)

        collectTau (TCon _ n) acc = case U.nstname n g of

            Nothing -> acc

            Just tn

                | tn `elem` acc = acc

                | Just (SymA {name}) <- tn.findit g = if name `elem` acc then acc else name:acc

                | otherwise = acc   -- do not complain about unknown type constructors

        getpos tn

            | Just (SymA {pos}) <- QName.findit tn g = pos

            | otherwise = Position.null

        checkmutual [] = stio ()

        checkmutual [a] = stio ()

        checkmutual (a:as) = U.error (getpos a) (msgdoc ("Mutual recursive type aliases "

                                ++ joined ", " (map (flip QName.nice g) (a:as))))

        checkselfref (tn, deps)

            | tn `elem` deps = U.error (getpos tn) (msgdoc ("Self referential type alias `"

                                ++ QName.nice tn g ++ "`"))

            | otherwise = stio ()

    changeST Global.{sub <- SubSt.{definitions=reverse other}}     -- no more type aliases henceforth

    foreach agrps checkmutual

    foreach adeps checkselfref

    g <- getST

    unless (g.sub.errors > 0) do foreach sdefs (T.transdef [] (VName g.thisPack))

    stio ("type aliases", length adefs)