0N/ACopyright : (c) Christian Maeder and Uni Bremen 2003
0N/AMaintainer : maeder@tzi.de
0N/AStability : experimental
0N/APortability : portable
0N/A utility functions and computations of meaningful positions for
0N/A various data types of the abstract syntax
0N/A-- | recursively substitute type names within a type
0N/Arename :: (TypeId -> Kind -> Int -> Type) -> Type -> Type
0N/Arename m t = case t of
0N/A TypeName i k n -> m i k n
496N/A TypeAppl t1 t2 -> TypeAppl (rename m t1) (rename m t2)
0N/A ExpandedType t1 t2 -> ExpandedType (rename m t1) (rename m t2)
0N/A BracketType b l ps ->
0N/A BracketType b (map (rename m) l) ps
0N/A KindedType tk k ps ->
0N/A KindedType (rename m tk) k ps
0N/A MixfixType l -> MixfixType $ map (rename m) l
0N/A LazyType tl ps -> LazyType (rename m tl) ps
3320N/A ProductType l ps -> ProductType (map (rename m) l) ps
3320N/A FunType t1 a t2 ps -> FunType (rename m t1) a (rename m t2) ps
0N/A{- | decompose an 'ApplTerm' into an application of an operation and a
0N/A list of arguments -}
496N/AgetAppl :: Term -> Maybe (Id, TypeScheme, [Term])
0N/AgetAppl = thrdM reverse . getAppl2
496N/A thrdM :: (c -> c) -> Maybe (a, b, c) -> Maybe (a, b, c)
0N/A thrdM f = fmap ( \ (a, b, c) -> (a, b, f c))
0N/A getAppl2 :: Term -> Maybe (Id, TypeScheme, [Term])
0N/A getAppl2 t = case t of
0N/A TypedTerm trm q _ _ -> case q of
0N/A QualOp _ (InstOpId i _ _) sc _ -> Just (i, sc, [])
0N/A QualVar (VarDecl v ty _ _) -> Just (v, simpleTypeScheme ty, [])
0N/A ApplTerm t1 t2 _ -> thrdM (t2:) $ getAppl2 t1
0N/A-- | extract bindings from an analysed pattern
0N/AextractVars :: Pattern -> [VarDecl]
extractVars p1 ++ extractVars p2
TupleTerm pats _ -> concatMap extractVars pats
TypedTerm p _ _ _ -> extractVars p
AsPattern v p2 _ -> getVd v ++ extractVars p2
ResolvedMixTerm _ pats _ -> concatMap extractVars pats
where getVd vd@(VarDecl v _ _ _) = if showId v "" == "_" then [] else [vd]
-- | construct term from id
mkOpTerm :: Id -> TypeScheme -> Term
mkOpTerm i sc = QualOp Op (InstOpId i [] []) sc []
mkForall :: [GenVarDecl] -> Term -> Term
mkForall vl f = if null vl then f else QuantifiedTerm Universal vl f []
-- | construct application with curried arguments
mkApplTerm :: Term -> [Term] -> Term
mkApplTerm trm args = if null args then trm
else mkApplTerm (ApplTerm trm (head args) []) $ tail args
-- | get the type of a constructor with given curried argument types
getConstrType :: DataPat -> Partiality -> [Type] -> Type
getConstrType dt p ts = (case p of
Partial -> addPartiality ts) $
foldr ( \ c r -> FunType c FunArr r [] )
-- | make function arrow partial after some arguments
addPartiality :: [a] -> Type -> Type
addPartiality as t = case as 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
_:rs -> getPartiality rs t2
LazyType _ _ -> if null as then Partial else error "getPartiality"
type DataPat = (Id, [TypeArg], Kind)
-- | compute the type given by the input
typeIdToType :: DataPat -> Type
typeIdToType (i, nAs, k) = let
fullKind = typeArgsListToKind nAs k
ti = TypeName i fullKind 0
mkType n ty ((TypeArg ai ak _ _): rest) =
mkType (n-1) (TypeAppl ty (TypeName ai ak n)) rest
-- | extent a kind to expect further type arguments
typeArgsListToKind :: [TypeArg] -> Kind -> Kind
typeArgsListToKind tArgs k =
else typeArgsListToKind (init tArgs)
(FunKind (( \ (TypeArg _ xk _ _) -> xk) $ last tArgs) k [])
-- | generate a comparison string
expected :: PrettyPrint a => a -> a -> String
"\n expected: " ++ showPretty a
"\n found: " ++ showPretty b "\n"
-- ---------------------------------------------------------------------
posOfKind :: Kind -> [Pos]
ClassKind c _ -> posOfId c
posOfVars :: Vars -> [Pos]
posOfTypeArg :: TypeArg -> [Pos]
posOfTypeArg (TypeArg t _ _ ps) = firstPos [t] ps
posOfTypePattern :: TypePattern -> [Pos]
TypePattern t _ _ -> posOfId t
TypePatternToken t -> tokPos t
MixfixTypePattern ts -> posOf ts
BracketTypePattern _ ts ps -> firstPos ts ps
TypePatternArg (TypeArg t _ _ _) _ -> posOfId t
posOfType :: Type -> [Pos]
TypeName i _ _ -> posOfId i
TypeAppl t1 t2 -> posOf [t1, t2]
ExpandedType t1 t2 -> posOf [t1, t2]
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
posOfTerm :: Term -> [Pos]
QualVar v -> posOfVarDecl v
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
MixTypeTerm _ t ps -> firstPos [t] ps
MixfixTerm ts -> posOf ts
BracketTerm _ ts ps -> firstPos ts ps
AsPattern v _ ps -> firstPos [v] ps
posOfVarDecl :: VarDecl -> [Pos]
posOfVarDecl (VarDecl v _ _ ps) = firstPos [v] ps
instance PosItem a => PosItem [a] where
get_pos = concatMap get_pos
instance PosItem a => PosItem (a, b) where
get_pos (a, _) = get_pos a
instance PosItem a => PosItem (
Set.Set a) where