
-- ==========================================================--
-- === Base declarations                      BaseDefs.hs ===--
-- ==========================================================--

module BaseDefs where

----------------------------------------------------------
-- Useful polymorphic types                             --
----------------------------------------------------------

type AList a b = [(a, b)]

type DefnGroup a = [(Bool, [a])]

type ST a b = b -> (a, b)

data ATree a b = ALeaf
               | ABranch (ATree a b) a b (ATree a b) Int
                 deriving (Eq)

--1.3:data Maybe a = Nothing
--             | Just a
--               deriving (Eq)

data Reply a b = Ok a
               | Fail b
                 deriving (Eq)


----------------------------------------------------------
-- Misc Utils stuff                                     --
----------------------------------------------------------

type NameSupply = Int

type Oseq = Int -> Int -> [Char]

type Iseq = Oseq -> Oseq

data Set a = MkSet [a]
             deriving (Eq)

type Bag a = [a]


----------------------------------------------------------
-- Flags                                                --
----------------------------------------------------------

data Flag = Typecheck      -- don't do strictness analysis
          | Simp           -- do HExpr-simplification (usually a bad idea)
          | NoCaseOpt      -- don't do case-of-case optimisation
          | ShowHExpr      -- print HExprs as they are generated
          | NoPretty       -- don't clean up the program after \-lifting
          | NoFormat       -- don't prettily format first order output
          | NoBaraki       -- don't use embedding-closure pairs
          | SimpleInv      -- use simplistic version of inverse
          | PolyLim Int    -- how hard to work in Baraki dept for
          | MonoLim Int    -- polymorphism and approx FPs respectively
          | ForceAll       -- force all thunks before analysis
          | DryRun         -- quick pass to check lattice table
          | LowerLim Int   -- lower threshold for approx fixed pts
          | UpperLim Int   -- upper threshold for approx fixed pts
          | ScaleUp Int    -- scale up target ratio
            deriving (Eq)

bdDefaultSettings
   = [PolyLim 10000, MonoLim 10000, LowerLim 0, UpperLim 1000000, ScaleUp 20]

bdDryRunSettings
   = [NoBaraki, LowerLim 0, UpperLim 0, PolyLim 1, MonoLim 1, ScaleUp 20]


----------------------------------------------------------
-- Provides a way for the system to give a              --
-- running commentary about what it is doing            --
----------------------------------------------------------

data SAInfo = SAResult    String Domain Route
            | SASearch    ACMode String Int Int
            | SASizes     String [OneFuncSize] [OneFuncSize]
            | SAHExpr     String (HExpr Naam)
            | SASL        [Route] [Route]
            | SAGiveUp    [String]
              deriving ()


----------------------------------------------------------
-- Stuff for the Approx Fixed Pts business              --
----------------------------------------------------------

data ExceptionInt a = MkExInt Int [a]
                      deriving (Eq, Ord, Show{-was:Text-})

{- partain: moved from SmallerLattice.hs -}
instance (Show{-was:Text-} a, Ord a) => Num (ExceptionInt a) where

   (MkExInt i1 xs1) + (MkExInt i2 xs2)
      = MkExInt (i1 + i2) (xs1 ++ xs2)

   (MkExInt i1 xs1) * (MkExInt i2 xs2)
      = MkExInt (i1 * i2) (xs1 ++ xs2)

type DomainInt = ExceptionInt Domain

type DInt = (Domain, Int)

type OneFuncSize = (Int, [Domain])

type Sequence = ([[OneFuncSize]], [[OneFuncSize]])


----------------------------------------------------------
-- Basic syntax trees for Core programs                 --
----------------------------------------------------------

type Naam = [Char]

type Alter = AlterP Naam
type AlterP a = ([a],                  -- parameters to pattern-match on
                 CExprP a)             -- resulting expressions

type ScValue = ScValueP Naam
type ScValueP a = ([a],                -- list of arguments for the SC
                   CExprP a)           -- body of the SC

type CoreProgram = CoreProgramP Naam
type CoreProgramP a = ([TypeDef],      -- type definitions
                       [(Naam,         -- list of SC names ...
                         ScValueP a)]) --    and their definitions

type AtomicProgram = ([TypeDef],       -- exactly like a CoreProgram except
                      CExpr)           -- all the SCs are put into a letrec

type TypeDef = (Naam,                  -- the type's name
                [Naam],                -- schematic type variables
                [ConstrAlt])           -- constructor list

type ConstrAlt = (Naam,                -- constructor's name
                  [TDefExpr])          -- list of argument types

data TDefExpr                          -- type expressions for definitions
                = TDefVar Naam         -- type variables
                | TDefCons             -- constructed types
                     Naam              --    constructor's name
                     [TDefExpr]        --    constituent type expressions
                  deriving (Eq)


----------------------------------------------------------
-- Core expressions                                     --
----------------------------------------------------------

type CExpr = CExprP Naam

data CExprP a                              -- Core expressions
             = EVar Naam                   -- variables
             | ENum Int                    -- numbers
             | EConstr Naam                -- constructors
             | EAp (CExprP a) (CExprP a)   -- applications
             | ELet                        -- lets and letrecs
                  Bool                     -- True == recursive
                  [(a, CExprP a)]
                  (CExprP a)
             | ECase                       -- case statements
                  (CExprP a)
                  [(Naam, AlterP a)]
             | ELam                        -- lambda abstractions
                  [a]
                  (CExprP a)
               deriving (Eq)


----------------------------------------------------------
-- Annotated Core expressions                           --
----------------------------------------------------------

type AnnExpr a b = (b, AnnExpr' a b)

data AnnExpr' a b
        = AVar Naam
        | ANum Int
        | AConstr Naam
        | AAp (AnnExpr a b) (AnnExpr a b)
        | ALet Bool [AnnDefn a b] (AnnExpr a b)
        | ACase (AnnExpr a b) [AnnAlt a b]
        | ALam [a] (AnnExpr a b)
          deriving (Eq)

type AnnDefn a b = (a, AnnExpr a b)

type AnnAlt a b  = (Naam, ([a], (AnnExpr a b)))

type AnnProgram a b = [(Naam, [a], AnnExpr a b)]


----------------------------------------------------------
-- Stuff for the #*$*%*%* Lambda-Lifter                 --
----------------------------------------------------------

data Eqn = EqnNVC Naam (Set Naam) (Set Naam)
           deriving (Eq)


----------------------------------------------------------
-- Typechecker stuff                                    --
----------------------------------------------------------

type TVName = ([Int],[Int])

type Message = [Char]

data TExpr = TVar TVName
           | TArr TExpr TExpr
           | TCons [Char] [TExpr]
             deriving (Eq)

data TypeScheme = Scheme [TVName] TExpr
                  deriving (Eq)

type Subst = AList TVName TExpr

type TcTypeEnv = AList Naam TypeScheme

type TypeEnv = AList Naam TExpr

type TypeNameSupply = TVName

type TypeInfo = (Subst, TExpr, AnnExpr Naam TExpr)

type TypeDependancy = DefnGroup Naam


----------------------------------------------------------
-- Domain stuff                                         --
----------------------------------------------------------
-- Assumes that all Domain values passed are in         --
-- uncurried form, ie no (Func _ (Func _ _)).           --
-- Functions generating denormalised                    --
-- function Domains must normalise them themselves.     --
----------------------------------------------------------

type Point = (Domain, Route)

data FrontierElem = MkFrel [Route]
                    deriving (Eq, Ord, Show{-was:Text-})

data Frontier = Min1Max0 Int [FrontierElem] [FrontierElem]
                deriving (Eq, Ord, Show{-was:Text-})

data Domain = Two
            | Lift1 [Domain]
            | Lift2 [Domain]
            | Func  [Domain] Domain
              deriving (Eq, Ord, Show, Read)

data Route = Zero
           | One
           | Stop1
           | Up1 [Route]
           | Stop2
           | Up2
           | UpUp2 [Route]
           | Rep Rep
             deriving (Eq, Ord, Show{-was:Text-})

data Rep = RepTwo Frontier
         | Rep1 Frontier [Rep]
         | Rep2 Frontier Frontier [Rep]
           deriving (Eq, Ord, Show{-was:Text-})

data DExpr = DXTwo
           | DXLift1  [DExpr]
           | DXLift2  [DExpr]
           | DXFunc   [DExpr] DExpr
           | DXVar    String
             deriving (Eq)

type RSubst = AList String Route

type DSubst = AList String Domain

type DRRSubst = AList String (Domain, Route, Route)

type DExprEnv = AList String DExpr

data ConstrElem = ConstrRec
                | ConstrVar Int
                  deriving (Eq, Ord, Show{-was:Text-})


----------------------------------------------------------
-- Abs and Conc stuff                                   --
----------------------------------------------------------

data ACMode = Safe
            | Live
              deriving (Eq)

----------------------------------------------------------
-- Frontier search stuff                                --
----------------------------------------------------------

type MemoList = AList [Route] Route

data AppInfo = A2
                   -- trivial case
             | ALo1
                   -- low factor in function to Lift1
             | AHi1 Int Int Domain
                   -- a high factor in a function to Lift1.
                   -- First Int is arity of low factor, second is
                   -- the index of the high factor sought.
                   -- Domain is of the high factor sought.
             | ALo2
                   -- low factor in function to Lift2
             | AMid2
                   -- middle factor in function to Lift2
             | AHi2 Int Int Domain
                   -- a high factor in a function to Lift1.
                   -- First Int is arity of low & middle factors,
                   -- second is the index of the high factor sought.
                   -- Domain is of high factor sought.
               deriving (Eq)


----------------------------------------------------------
-- Abstract expression trees                            --
----------------------------------------------------------

data HExpr a = HApp (HExpr a) (HExpr a)
             | HVAp (HExpr a) [HExpr a]
             | HLam [a] (HExpr a)
             | HVar a
             | HMeet [HExpr a]  -- must be at least one in list
             | HPoint Route
             | HTable (AList Route (HExpr a))
               deriving (Eq, Show{-was:Text-})


----------------------------------------------------------
-- Prettyprinter stuff                                  --
----------------------------------------------------------

type PrPoint =  [Int]

type PrDomain =  [PrPoint]


----------------------------------------------------------
-- Parser stuff                                         --
----------------------------------------------------------

type Token =  (Int, [Char])

data PResult a = PFail [Token]
               | POk a [Token]
                 deriving (Eq)

type Parser a =  [Token] -> PResult a

data PartialExpr = NoOp
                 | FoundOp Naam CExpr
                   deriving (Eq)


-- ===============================================================--
-- === Definition of the static component                      ===--
-- ===---------------------------------------------------------===--
-- === The static component carries around all information     ===--
-- === which remains unchanged throughout strictness analysis. ===--
-- === This avoids having to pass around vast hordes of        ===--
-- === parameters containing static information.               ===--
-- ===============================================================--

type StaticComponent
    =  (
     	 DExprEnv,
     	 -- == AList Naam DExpr, the program's types

         DSubst,
         -- == AList Naam Domain, the simplest domains of functions

         AList Naam [ConstrElem],
         -- information on constructors

         AList Naam [Naam],
         -- information on pseudo-params inserted to fix free vars

         [Flag],
         -- set of flags altering system operation

         (Int, Int, Int, Int, Int),
         -- polymorphic and monomorphic Baraki limits,
         -- and lower and upper limits for lattice sizes
         -- and the scaleup ratio

         AList Domain Int
         -- the lattice size table
        )


-- ==========================================================--
-- === end                                    BaseDefs.hs ===--
-- ==========================================================--
