hets/HasCASL/AsUtils.hs

	AsUtils.hs revision e1839fb37a3a2ccd457464cb0dcc5efd466dbe22
{- |
Module      :  $Header$
Copyright   :  (c) Christian Maeder and Uni Bremen 2003
Licence     :  similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt

Maintainer  :  hets@tzi.de
Stability   :  experimental
Portability :  portable

   compute meaningful positions for various data types of the abstract syntax
-}

module HasCASL.AsUtils where

import HasCASL.As
import HasCASL.PrintAs -- to reexport instances
import Common.Id
import Common.PrettyPrint

-- | get the type of a constructor with given curried argument types
getConstrType :: Type -> Partiality -> [Type] -> Type
getConstrType dt p ts = (case p of
     Total -> id
     Partial -> addPartiality ts) $
               foldr ( \ c r -> FunType c FunArr r [] ) dt ts

-- | make function arrow partial after some arguments
addPartiality :: [a] -> Type -> Type
addPartiality as t = case as of
        [] -> LazyType t []
    _ : rs -> case t of
       FunType t1 a t2 ps -> if null rs then FunType t1 PFunArr t2 ps
           else FunType t1 a (addPartiality rs t2) ps
       _ -> error "addPartiality"

-- | get the partiality from a constructor type
-- with a given number of curried arguments
getPartiality :: [a] -> Type -> Partiality
getPartiality as t = case t of
   KindedType ty _ _ -> getPartiality as ty
   FunType _ a t2 _ -> case as of
     [] -> Total
     [_] -> case a of
        PFunArr  -> Partial
        PContFunArr -> Partial
        _ -> Total
     _:rs -> getPartiality rs t2
   LazyType _ _ -> if null as then Partial else error "getPartiality"
   _ -> Total

-- | extent a kind to expect further type arguments
typeArgsListToKind :: [TypeArg] -> Kind -> Kind
typeArgsListToKind tArgs k =
    if null tArgs then k
       else typeArgsListToKind (init tArgs)
        (FunKind (( \ (TypeArg _ xk _ _) -> xk) $ last tArgs) k [])

-- | generate a comparison string
expected :: PrettyPrint a => a -> a -> String
expected a b =
    "\n  expected: " ++ showPretty a
    "\n     found: " ++ showPretty b "\n"

instance PosItem Kind where
    get_pos = Just . posOfKind

posOfKind :: Kind -> Pos
posOfKind k =
    case k of
    Universe ps -> if null ps then nullPos else head ps
    MissingKind -> nullPos
    ClassKind c _ -> posOfId c
    Downset _ t _ ps -> firstPos [t] ps
    Intersection ks ps -> firstPos ks ps
    FunKind k1 _ ps -> firstPos [k1] ps
    ExtKind ek _ ps -> firstPos [ek] ps

-- ---------------------------------------------------------------------

posOfVars :: Vars -> Pos
posOfVars vr =
    case vr of
    Var v -> posOfId v
    VarTuple vs ps -> firstPos vs ps

instance PosItem Vars where
    get_pos = Just . posOfVars

instance PosItem TypePattern where
    get_pos = Just . posOfTypePattern

instance PosItem TypeArg where
    get_pos (TypeArg t _ _ _) = Just $ posOfId t

posOfTypePattern :: TypePattern -> Pos
posOfTypePattern pat =
    case pat of
    TypePattern t _ _ -> posOfId t
    TypePatternToken t -> tokPos t
    MixfixTypePattern ts -> posOf ts
    BracketTypePattern _ ts ps -> firstPos ts ps
    TypePatternArg (TypeArg t _ _ _) _ -> posOfId t
-- ---------------------------------------------------------------------

instance PosItem TypeScheme where
    get_pos (TypeScheme tArgs _ ps) = Just $ firstPos tArgs ps

instance PosItem Type where
    get_pos = Just . posOfType

posOfType :: Type -> Pos
posOfType ty =
    case ty of
    TypeName i _ _ -> posOfId i
    TypeAppl t1 t2 -> posOf [t1, t2]
    TypeToken t -> tokPos t
    BracketType _ ts ps -> firstPos ts ps
    KindedType t _ ps -> firstPos [t] ps
    MixfixType ts -> posOf ts
    LazyType t ps -> firstPos [t] ps
    ProductType ts ps -> firstPos ts ps
    FunType t1 _ t2 ps -> firstPos [t1,t2] ps

-- ---------------------------------------------------------------------
instance PosItem Term where
    get_pos = Just . posOfTerm

posOfTerm :: Term -> Pos
posOfTerm trm =
    case trm of
    QualVar v _ ps -> firstPos [v] ps
    QualOp _ (InstOpId i _ ps) _ qs -> firstPos [i] (ps++qs)
    ResolvedMixTerm i _ _ -> posOfId i
    ApplTerm t1 t2 ps -> firstPos [t1, t2] ps
    TupleTerm ts ps -> firstPos ts ps
    TypedTerm t _ _ ps -> firstPos [t] ps
    QuantifiedTerm _ _ t ps -> firstPos [t] ps
    LambdaTerm _ _ t ps -> firstPos [t] ps
    CaseTerm t _ ps -> firstPos [t] ps
    LetTerm _ _ t ps -> firstPos [t] ps
    TermToken t -> tokPos t
    MixTypeTerm _ t ps -> firstPos [t] ps
    MixfixTerm ts -> posOf ts
    BracketTerm _ ts ps -> firstPos ts ps
    AsPattern p1 p2 ps -> firstPos [p1, p2] ps

-- ---------------------------------------------------------------------

instance PosItem VarDecl where
    get_pos (VarDecl v _ _ ps) = Just $ firstPos [v] ps