Commit 8eb45ee8 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky

Converted literate haskell files into simple haskell files

parent 98d846e5
{- |
Module : $Header$
Description : Conversion of type representation
Copyright : (c) Wolfgang Lux
2011 - 2012 Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
The functions 'toType', 'toTypes', and 'fromType' convert Curry type
expressions into types and vice versa. The functions 'qualifyType' and
'unqualifyType' add and remove module qualifiers in a type, respectively.
When Curry type expression are converted with 'toType' or 'toTypes',
type variables are assigned ascending indices in the order of their
occurrence. It is possible to pass a list of additional type variables
to both functions which are assigned indices before those variables
occurring in the type. This allows preserving the order of type variables
in the left hand side of a type declaration.
-}
module Base.CurryTypes
( toQualType, toQualTypes, toType, toTypes, fromQualType, fromType
) where
import Data.List (nub)
import qualified Data.Map as Map (Map, fromList, lookup)
import Curry.Base.Ident
import qualified Curry.Syntax as CS
import Base.Expr
import Base.Messages (internalError)
import Base.Types
toQualType :: ModuleIdent -> [Ident] -> CS.TypeExpr -> Type
toQualType m tvs = qualifyType m . toType tvs
toQualTypes :: ModuleIdent -> [Ident] -> [CS.TypeExpr] -> [Type]
toQualTypes m tvs = map (qualifyType m) . toTypes tvs
toType :: [Ident] -> CS.TypeExpr -> Type
toType tvs ty = toType' (Map.fromList $ zip (tvs ++ newInTy) [0 ..]) ty
where newInTy = [tv | tv <- nub (fv ty), tv `notElem` tvs]
toTypes :: [Ident] -> [CS.TypeExpr] -> [Type]
toTypes tvs tys = map
(toType' (Map.fromList $ zip (tvs ++ newInTys) [0 ..])) tys
where newInTys = [tv | tv <- nub (concatMap fv tys), tv `notElem` tvs]
toType' :: Map.Map Ident Int -> CS.TypeExpr -> Type
toType' tvs (CS.ConstructorType tc tys)
= TypeConstructor tc (map (toType' tvs) tys)
toType' tvs (CS.VariableType tv) = case Map.lookup tv tvs of
Just tv' -> TypeVariable tv'
Nothing -> internalError $ "Base.CurryTypes.toType': " ++ show tv
toType' tvs (CS.TupleType tys)
| null tys = TypeConstructor (qualify unitId) []
| otherwise = TypeConstructor (qualify $ tupleId $ length tys') tys'
where tys' = map (toType' tvs) tys
toType' tvs (CS.ListType ty)
= TypeConstructor (qualify listId) [toType' tvs ty]
toType' tvs (CS.ArrowType ty1 ty2)
= TypeArrow (toType' tvs ty1) (toType' tvs ty2)
toType' tvs (CS.RecordType fs rty)
= TypeRecord fs' rty'
where
fs' = concatMap (\ (ls, ty) -> map (\ l -> (l, toType' tvs ty)) ls) fs
rty' = case rty of
Nothing -> Nothing
Just ty -> case toType' tvs ty of
TypeVariable tv -> Just tv
_ -> internalError $ "Base.CurryTypes.toType' " ++ show ty
fromQualType :: ModuleIdent -> Type -> CS.TypeExpr
fromQualType m = fromType . unqualifyType m
fromType :: Type -> CS.TypeExpr
fromType (TypeConstructor tc tys)
| isTupleId c = CS.TupleType tys'
| c == unitId && null tys = CS.TupleType []
| c == listId && length tys == 1 = CS.ListType (head tys')
| otherwise = CS.ConstructorType tc tys'
where c = unqualify tc
tys' = map fromType tys
fromType (TypeVariable tv) = CS.VariableType
(if tv >= 0 then identSupply !! tv else mkIdent ('_' : show (-tv)))
fromType (TypeConstrained tys _) = fromType (head tys)
fromType (TypeArrow ty1 ty2) =
CS.ArrowType (fromType ty1) (fromType ty2)
fromType (TypeSkolem k) =
CS.VariableType $ mkIdent $ "_?" ++ show k
fromType (TypeRecord fs rty) = CS.RecordType
(map (\ (l, ty) -> ([l], fromType ty)) fs)
((fromType . TypeVariable) `fmap` rty)
\paragraph{Types}
The functions \texttt{toType}, \texttt{toTypes}, and \texttt{fromType}
convert Curry type expressions into types and vice versa. The
functions \texttt{qualifyType} and \texttt{unqualifyType} add and
remove module qualifiers in a type, respectively.
When Curry type expression are converted with \texttt{toType} or
\texttt{toTypes}, type variables are assigned ascending indices in the
order of their occurrence. It is possible to pass a list of additional
type variables to both functions which are assigned indices before
those variables occurring in the type. This allows preserving the
order of type variables in the left hand side of a type declaration.
\begin{verbatim}
> module Base.CurryTypes
> ( toQualType, toQualTypes, toType, toTypes, fromQualType, fromType
> ) where
> import Data.List (nub)
> import qualified Data.Map as Map (Map, fromList, lookup)
> import Curry.Base.Ident
> import qualified Curry.Syntax as CS
> import Base.Expr
> import Base.Messages (internalError)
> import Base.Types
> toQualType :: ModuleIdent -> [Ident] -> CS.TypeExpr -> Type
> toQualType m tvs = qualifyType m . toType tvs
> toQualTypes :: ModuleIdent -> [Ident] -> [CS.TypeExpr] -> [Type]
> toQualTypes m tvs = map (qualifyType m) . toTypes tvs
> toType :: [Ident] -> CS.TypeExpr -> Type
> toType tvs ty = toType' (Map.fromList $ zip (tvs ++ newInTy) [0 ..]) ty
> where newInTy = [tv | tv <- nub (fv ty), tv `notElem` tvs]
> toTypes :: [Ident] -> [CS.TypeExpr] -> [Type]
> toTypes tvs tys = map
> (toType' (Map.fromList $ zip (tvs ++ newInTys) [0 ..])) tys
> where newInTys = [tv | tv <- nub (concatMap fv tys), tv `notElem` tvs]
> toType' :: Map.Map Ident Int -> CS.TypeExpr -> Type
> toType' tvs (CS.ConstructorType tc tys)
> = TypeConstructor tc (map (toType' tvs) tys)
> toType' tvs (CS.VariableType tv) = case Map.lookup tv tvs of
> Just tv' -> TypeVariable tv'
> Nothing -> internalError $ "Base.CurryTypes.toType': " ++ show tv
> toType' tvs (CS.TupleType tys)
> | null tys = TypeConstructor (qualify unitId) []
> | otherwise = TypeConstructor (qualify $ tupleId $ length tys') tys'
> where tys' = map (toType' tvs) tys
> toType' tvs (CS.ListType ty)
> = TypeConstructor (qualify listId) [toType' tvs ty]
> toType' tvs (CS.ArrowType ty1 ty2)
> = TypeArrow (toType' tvs ty1) (toType' tvs ty2)
> toType' tvs (CS.RecordType fs rty)
> = TypeRecord fs' rty'
> where
> fs' = concatMap (\ (ls, ty) -> map (\ l -> (l, toType' tvs ty)) ls) fs
> rty' = case rty of
> Nothing -> Nothing
> Just ty -> case toType' tvs ty of
> TypeVariable tv -> Just tv
> _ -> internalError $ "Base.CurryTypes.toType' " ++ show ty
> fromQualType :: ModuleIdent -> Type -> CS.TypeExpr
> fromQualType m = fromType . unqualifyType m
> fromType :: Type -> CS.TypeExpr
> fromType (TypeConstructor tc tys)
> | isTupleId c = CS.TupleType tys'
> | c == unitId && null tys = CS.TupleType []
> | c == listId && length tys == 1 = CS.ListType (head tys')
> | otherwise = CS.ConstructorType tc tys'
> where c = unqualify tc
> tys' = map fromType tys
> fromType (TypeVariable tv) = CS.VariableType
> (if tv >= 0 then identSupply !! tv else mkIdent ('_' : show (-tv)))
> fromType (TypeConstrained tys _) = fromType (head tys)
> fromType (TypeArrow ty1 ty2) =
> CS.ArrowType (fromType ty1) (fromType ty2)
> fromType (TypeSkolem k) =
> CS.VariableType $ mkIdent $ "_?" ++ show k
> fromType (TypeRecord fs rty) = CS.RecordType
> (map (\ (l, ty) -> ([l], fromType ty)) fs)
> ((fromType . TypeVariable) `fmap` rty)
{- |
Module : $Header$
Description : Nested Environments
Copyright : (c) 1999 - 2003 Wolfgang Lux
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
The 'NestEnv' environment type extends top-level environments to manage
nested scopes. Local scopes allow only for a single, unambiguous definition.
As a matter of convenience, the module 'TopEnv' is exported by
the module 'NestEnv'. Thus, only the latter needs to be imported.
-}
module Base.NestEnv
( module Base.TopEnv
, NestEnv, bindNestEnv, qualBindNestEnv, lookupNestEnv, qualLookupNestEnv
, toplevelEnv, globalEnv, nestEnv
) where
import qualified Data.Map as Map
import Curry.Base.Ident
import Base.Messages (internalError)
import Base.TopEnv
data NestEnv a
= GlobalEnv (TopEnv a)
| LocalEnv (NestEnv a) (Map.Map Ident a)
deriving Show
instance Functor NestEnv where
fmap f (GlobalEnv env) = GlobalEnv (fmap f env)
fmap f (LocalEnv genv env) = LocalEnv (fmap f genv) (fmap f env)
globalEnv :: TopEnv a -> NestEnv a
globalEnv = GlobalEnv
nestEnv :: NestEnv a -> NestEnv a
nestEnv env = LocalEnv env Map.empty
toplevelEnv :: NestEnv a -> TopEnv a
toplevelEnv (GlobalEnv env) = env
toplevelEnv (LocalEnv genv _) = toplevelEnv genv
bindNestEnv :: Ident -> a -> NestEnv a -> NestEnv a
bindNestEnv x y (GlobalEnv env)
= GlobalEnv $ bindTopEnv "NestEnv.bindNestEnv" x y env
bindNestEnv x y (LocalEnv genv env) = case Map.lookup x env of
Just _ -> internalError $ "NestEnv.bindNestEnv " ++ show x ++ " failed"
Nothing -> LocalEnv genv $ Map.insert x y env
qualBindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a
qualBindNestEnv x y (GlobalEnv env)
= GlobalEnv $ qualBindTopEnv "NestEnv.qualBindNestEnv" x y env
qualBindNestEnv x y (LocalEnv genv env)
| isQualified x = internalError "NestEnv.qualBindNestEnv"
| otherwise = case Map.lookup x' env of
Just _ -> internalError "NestEnv.qualBindNestEnv"
Nothing -> LocalEnv genv $ Map.insert x' y env
where x' = unqualify x
lookupNestEnv :: Ident -> NestEnv a -> [a]
lookupNestEnv x (GlobalEnv env) = lookupTopEnv x env
lookupNestEnv x (LocalEnv genv env) = case Map.lookup x env of
Just y -> [y]
Nothing -> lookupNestEnv x genv
qualLookupNestEnv :: QualIdent -> NestEnv a -> [a]
qualLookupNestEnv x env
| isQualified x = qualLookupTopEnv x $ toplevelEnv env
| otherwise = lookupNestEnv (unqualify x) env
% $Id: NestEnv.lhs,v 1.11 2003/10/04 17:04:23 wlux Exp $
%
% Copyright (c) 1999-2003, Wolfgang Lux
% See LICENSE for the full license.
%
\nwfilename{NestEnv.lhs}
\subsection{Nested Environments}
The \texttt{NestEnv} environment type extends top-level environments
(see section~\ref{sec:toplevel-env}) to manage nested scopes. Local
scopes allow only for a single, unambiguous definition.
As a matter of convenience, the module \texttt{TopEnv} is exported by
the module \texttt{NestEnv}. Thus, only the latter needs to be imported.
\begin{verbatim}
> module Base.NestEnv
> ( module Base.TopEnv
> , NestEnv, bindNestEnv, qualBindNestEnv, lookupNestEnv, qualLookupNestEnv
> , toplevelEnv, globalEnv, nestEnv
> ) where
> import qualified Data.Map as Map
> import Curry.Base.Ident
> import Base.Messages (internalError)
> import Base.TopEnv
> data NestEnv a
> = GlobalEnv (TopEnv a)
> | LocalEnv (NestEnv a) (Map.Map Ident a)
> deriving Show
> instance Functor NestEnv where
> fmap f (GlobalEnv env) = GlobalEnv (fmap f env)
> fmap f (LocalEnv genv env) = LocalEnv (fmap f genv) (fmap f env)
> globalEnv :: TopEnv a -> NestEnv a
> globalEnv = GlobalEnv
> nestEnv :: NestEnv a -> NestEnv a
> nestEnv env = LocalEnv env Map.empty
> toplevelEnv :: NestEnv a -> TopEnv a
> toplevelEnv (GlobalEnv env) = env
> toplevelEnv (LocalEnv genv _) = toplevelEnv genv
> bindNestEnv :: Ident -> a -> NestEnv a -> NestEnv a
> bindNestEnv x y (GlobalEnv env)
> = GlobalEnv $ bindTopEnv "NestEnv.bindNestEnv" x y env
> bindNestEnv x y (LocalEnv genv env) = case Map.lookup x env of
> Just _ -> internalError $ "NestEnv.bindNestEnv " ++ show x ++ " failed"
> Nothing -> LocalEnv genv $ Map.insert x y env
> qualBindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a
> qualBindNestEnv x y (GlobalEnv env)
> = GlobalEnv $ qualBindTopEnv "NestEnv.qualBindNestEnv" x y env
> qualBindNestEnv x y (LocalEnv genv env)
> | isQualified x = internalError "NestEnv.qualBindNestEnv"
> | otherwise = case Map.lookup x' env of
> Just _ -> internalError "NestEnv.qualBindNestEnv"
> Nothing -> LocalEnv genv $ Map.insert x' y env
> where x' = unqualify x
> lookupNestEnv :: Ident -> NestEnv a -> [a]
> lookupNestEnv x (GlobalEnv env) = lookupTopEnv x env
> lookupNestEnv x (LocalEnv genv env) = case Map.lookup x env of
> Just y -> [y]
> Nothing -> lookupNestEnv x genv
> qualLookupNestEnv :: QualIdent -> NestEnv a -> [a]
> qualLookupNestEnv x env
> | isQualified x = qualLookupTopEnv x $ toplevelEnv env
> | otherwise = lookupNestEnv (unqualify x) env
\end{verbatim}
{- |
Module : $Header$
Description : Computation of strongly connected components
Copyright : (c) 2000, 2002 - 2003 Wolfgang Lux
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
At various places in the compiler we had to partition a list of
declarations into strongly connected components. The function
'scc' computes this relation in two steps. First, the list is
topologically sorted downwards using the 'defs' relation.
Then the resulting list is sorted upwards using the 'uses' relation
and partitioned into the connected components. Both relations
are computed within this module using the bound and free names of each
declaration.
In order to avoid useless recomputations, the code in the module first
decorates the declarations with their bound and free names and a
unique number. The latter is only used to provide a trivial ordering
so that the declarations can be used as set elements.
-}
module Base.SCC (scc) where
import qualified Data.Set as Set (empty, member, insert)
data Node a b = Node { key :: Int, bvs :: [b], fvs :: [b], node :: a }
instance Eq (Node a b) where
n1 == n2 = key n1 == key n2
instance Ord (Node b a) where
n1 `compare` n2 = key n1 `compare` key n2
scc :: Eq b => (a -> [b]) -- ^entities defined by node
-> (a -> [b]) -- ^entities used by node
-> [a] -- ^list of nodes
-> [[a]] -- ^strongly connected components
scc bvs' fvs' = map (map node) . tsort' . tsort . zipWith wrap [0 ..]
where wrap i n = Node i (bvs' n) (fvs' n) n
tsort :: Eq b => [Node a b] -> [Node a b]
tsort xs = snd (dfs xs Set.empty []) where
dfs [] marks stack = (marks,stack)
dfs (x : xs') marks stack
| x `Set.member` marks = dfs xs' marks stack
| otherwise = dfs xs' marks' (x : stack')
where (marks',stack') = dfs (defs x) (x `Set.insert` marks) stack
defs x1 = filter (any (`elem` fvs x1) . bvs) xs
tsort' :: Eq b => [Node a b] -> [[Node a b]]
tsort' xs = snd (dfs xs Set.empty []) where
dfs [] marks stack = (marks,stack)
dfs (x : xs') marks stack
| x `Set.member` marks = dfs xs' marks stack
| otherwise = dfs xs' marks' ((x : concat stack') : stack)
where (marks',stack') = dfs (uses x) (x `Set.insert` marks) []
uses x1 = filter (any (`elem` bvs x1) . fvs) xs
% $Id: SCC.lhs,v 1.3 2003/04/30 21:29:06 wlux Exp $
%
% Copyright (c) 2000,2002-2003, Wolfgang Lux
% See LICENSE for the full license.
%
\nwfilename{SCC.lhs}
\section{Computing strongly connected components}
At various places in the compiler we had to partition a list of
declarations into strongly connected components. The function
\texttt{scc} computes this relation in two steps. First, the list is
topologically sorted ``downwards'' using the \emph{defs} relation.
Then the resulting list is sorted ``upwards'' using the \emph{uses}
relation and partitioned into the connected components. Both relations
are computed within this module using the bound and free names of each
declaration.
In order to avoid useless recomputations, the code in the module first
decorates the declarations with their bound and free names and a
unique number. The latter is only used to provide a trivial ordering
so that the declarations can be used as set elements.
\begin{verbatim}
> module Base.SCC (scc) where
> import qualified Data.Set as Set (empty, member, insert)
> data Node a b = Node { key :: Int, bvs :: [b], fvs :: [b], node :: a }
> instance Eq (Node a b) where
> n1 == n2 = key n1 == key n2
> instance Ord (Node b a) where
> n1 `compare` n2 = key n1 `compare` key n2
> scc :: Eq b => (a -> [b]) -- ^entities defined by node
> -> (a -> [b]) -- ^entities used by node
> -> [a] -- ^list of nodes
> -> [[a]] -- ^strongly connected components
> scc bvs' fvs' = map (map node) . tsort' . tsort . zipWith wrap [0 ..]
> where wrap i n = Node i (bvs' n) (fvs' n) n
> tsort :: Eq b => [Node a b] -> [Node a b]
> tsort xs = snd (dfs xs Set.empty []) where
> dfs [] marks stack = (marks,stack)
> dfs (x : xs') marks stack
> | x `Set.member` marks = dfs xs' marks stack
> | otherwise = dfs xs' marks' (x : stack')
> where (marks',stack') = dfs (defs x) (x `Set.insert` marks) stack
> defs x1 = filter (any (`elem` fvs x1) . bvs) xs
> tsort' :: Eq b => [Node a b] -> [[Node a b]]
> tsort' xs = snd (dfs xs Set.empty []) where
> dfs [] marks stack = (marks,stack)
> dfs (x : xs') marks stack
> | x `Set.member` marks = dfs xs' marks stack
> | otherwise = dfs xs' marks' ((x : concat stack') : stack)
> where (marks',stack') = dfs (uses x) (x `Set.insert` marks) []
> uses x1 = filter (any (`elem` bvs x1) . fvs) xs
\end{verbatim}
{- |
Module : $Header$
Description : General substitution implementation
Copyright : (c) 2002 Wolfgang Lux
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
The module Subst implements substitutions. A substitution
sigma = {x_1 |-> t_1, ... ,x_n |-> t_n} is a finite mapping from
(finitely many) variables x_1, ... ,x_n to some kind of expression
or term.
In order to implement substitutions efficiently,
composed substitutions are marked with a boolean flag (see below).
-}
module Base.Subst
( Subst (..), IntSubst (..), idSubst, singleSubst, bindSubst, unbindSubst
, substToList, compose, substVar', isubstVar, restrictSubstTo
) where
import qualified Data.Map as Map
data Subst a b = Subst Bool (Map.Map a b) deriving Show
idSubst :: Ord a => Subst a b
idSubst = Subst False Map.empty
substToList :: Ord v => Subst v e -> [(v, e)]
substToList (Subst _ sigma) = Map.toList sigma
singleSubst :: Ord v => v -> e -> Subst v e
singleSubst v e = bindSubst v e idSubst
bindSubst :: Ord v => v -> e -> Subst v e -> Subst v e
bindSubst v e (Subst comp sigma) = Subst comp $ Map.insert v e sigma
unbindSubst :: Ord v => v -> Subst v e -> Subst v e
unbindSubst v (Subst comp sigma) = Subst comp $ Map.delete v sigma
-- For any substitution we have the following definitions:
-- sigma(x) = t_i if x = x_i
-- x otherwise
-- Dom(sigma) = {x_1, ... , x_n}
-- Codom(sigma) = {t_1, ... , t_n}
-- Note that obviously the set of variables must be a subset of the set
-- of expressions. Also it is usually possible to extend the substitution
-- to a homomorphism on the codomain of the substitution. This is
-- captured by the following class declaration:
-- class Ord v => Subst v e where
-- var :: v -> e
-- subst :: Subst v e -> e -> e
-- With the help of the injection 'var', we can then compute the
-- substitution for a variable sigma(v) and also the composition of
-- two substitutions sigma1 o sigma2(e) := sigma1(sigma2(e)).
-- A naive implementation of the composition were
--
-- compose sigma sigma' =
-- foldr (uncurry bindSubst) sigma (substToList (fmap (subst sigma) sigma'))
--
-- However, such an implementation is very inefficient because the
-- number of substiutions applied to a variable increases in
-- O(n) of the number of compositions.
-- A more efficient implementation is to apply 'subst' again to
-- the value substituted for a variable in Dom(sigma).
-- However, this is correct only as long as the result of the substitution
-- does not include any variables which are in Dom(sigma). For instance,
-- it is impossible to implement simple variable renamings in this way.
-- Therefore we use the simple strategy to apply 'subst' again
-- only in case of a substitution which was returned from 'compose'.
-- substVar :: Subst v e => Subst v e -> v -> e
-- substVar (Subst comp sigma) v = maybe (var v) subst' (Map.lookup v sigma)
-- where subst' = if comp then subst (Subst comp sigma) else id
compose :: (Ord v, Show v ,Show e) => Subst v e -> Subst v e -> Subst v e
compose sigma sigma' =
composed (foldr (uncurry bindSubst) sigma' (substToList sigma))
where composed (Subst _ sigma'') = Subst True sigma''
-- Unfortunately Haskell does not (yet) support multi-parameter type
-- classes. For that reason we have to define a separate class for each
-- kind of variable type for these functions. We implement
-- 'substVar' as a function that takes the class functions as an
-- additional parameters. As an example for the use of this function the
-- module includes a class 'IntSubst' for substitution whose
-- domain are integer numbers.
substVar' :: Ord v => (v -> e) -> (Subst v e -> e -> e)
-> Subst v e -> v -> e
substVar' var subst (Subst comp sigma) v =
maybe (var v) subst' (Map.lookup v sigma)
where subst' = if comp then subst (Subst comp sigma) else id
class IntSubst e where
ivar :: Int -> e
isubst :: Subst Int e -> e -> e
isubstVar :: IntSubst e => Subst Int e -> Int -> e
isubstVar = substVar' ivar isubst
-- The function 'restrictSubstTo' implements the restriction of a
-- substitution to a given subset of its domain.
restrictSubstTo :: Ord v => [v] -> Subst v e -> Subst v e
restrictSubstTo vs (Subst comp sigma) =
foldr (uncurry bindSubst) (Subst comp Map.empty)
(filter ((`elem` vs) . fst) (Map.toList sigma))
% Copyright (c) 2002, Wolfgang Lux
% See LICENSE for the full license.
%
\nwfilename{Subst.lhs}
\section{Substitutions}
The module {\tt Subst} implements substitutions. A substitution
$\sigma = \left\{x_1\mapsto t_1,\dots,x_n\mapsto t_n\right\}$ is a
finite mapping from (finitely many) variables $x_1,\dots,x_n$ to