content: {- |
  Module      :  ./HasCASL/FoldType.hs
  Description :  fold functions for types
  Copyright   :  (c) Christian Maeder and Uni Bremen 2007
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  folding types
  -}
  
  module HasCASL.FoldType where
  
  import HasCASL.As
  import Common.Id
  import qualified Data.Set as Set
  import Data.List as List
  
  data FoldTypeRec a = FoldTypeRec
    { foldTypeName :: Type -> Id -> RawKind -> Int -> a
    , foldTypeAppl :: Type -> a -> a -> a
    , foldExpandedType :: Type -> a -> a -> a
    , foldTypeAbs :: Type -> TypeArg -> a -> Range -> a
    , foldKindedType :: Type -> a -> Set.Set Kind -> Range -> a
    , foldTypeToken :: Type -> Token -> a
    , foldBracketType :: Type -> BracketKind -> [a] -> Range -> a
    , foldMixfixType :: Type -> [a] -> a }
  
  mapTypeRec :: FoldTypeRec Type
  mapTypeRec = FoldTypeRec
    { foldTypeName = const TypeName
    , foldTypeAppl = const TypeAppl
    , foldExpandedType = const ExpandedType
    , foldTypeAbs = const TypeAbs
    , foldKindedType = const KindedType
    , foldTypeToken = const TypeToken
    , foldBracketType = const BracketType
    , foldMixfixType = const MixfixType }
  
  foldType :: FoldTypeRec a -> Type -> a
  foldType r t = case t of
      TypeName i k c -> foldTypeName r t i k c
      TypeAppl t1 t2 -> foldTypeAppl r t (foldType r t1) $ foldType r t2
      ExpandedType t1 t2 -> foldExpandedType r t (foldType r t1) $ foldType r t2
      TypeAbs a ty p -> foldTypeAbs r t a (foldType r ty) p
      KindedType ty ks p -> foldKindedType r t (foldType r ty) ks p
      TypeToken tok -> foldTypeToken r t tok
      BracketType k ts p -> foldBracketType r t k (map (foldType r) ts) p
      MixfixType ts -> foldMixfixType r t $ map (foldType r) ts
  
  -- | recursively substitute type alias names within a type
  replAlias :: (Id -> RawKind -> Int -> Type) -> Type -> Type
  replAlias m = foldType mapTypeRec
      { foldTypeName = const m
      , foldExpandedType = \ et r1 r2 -> case (et, r1) of
          (ExpandedType t1@(TypeName {}) _, ExpandedType t3 _) | t1 == t3 ->
              ExpandedType t1 r2
          _ -> ExpandedType r1 r2 }
  
  -- | the type name components of a type
  leaves :: (Int -> Bool) -> Type -> [(Int, (Id, RawKind))]
  leaves b = foldType FoldTypeRec
    { foldTypeName = \ _ i k c -> [(c, (i, k)) | b c]
    , foldTypeAppl = const List.union
    , foldExpandedType = \ _ _ t2 -> t2
    , foldTypeAbs = \ _ (TypeArg i _ _ r c _ _) ty _ ->
          List.delete (c, (i, r)) ty
    , foldKindedType = \ _ ty _ _ -> ty
    , foldTypeToken = \ _ _ -> []
    , foldBracketType = \ _ _ _ _ -> []
    , foldMixfixType = \ _ _ -> [] }
  
  -- | uninstantiate, non-generalized, unknown type variables
  freeTVars :: Type -> [(Int, (Id, RawKind))]
  freeTVars = leaves (> 0)
  
  freeTVarIds :: Type -> [Id]
  freeTVarIds = map (fst . snd) . freeTVars
  