Commit 88cccd4e authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Formatting stuff

parent f26add68
......@@ -81,23 +81,23 @@ the order of their occurrence. This is handled by the function
> expandAliasType tys (TypeConstructor tc tys') =
> TypeConstructor tc (map (expandAliasType tys) tys')
> expandAliasType tys (TypeVariable n)
> | n >= 0 = tys !! n
> | n >= 0 = tys !! n
> | otherwise = TypeVariable n
> expandAliasType _ (TypeConstrained tys n) = TypeConstrained tys n
> expandAliasType tys (TypeArrow ty1 ty2) =
> expandAliasType _ (TypeConstrained tys n) = TypeConstrained tys n
> expandAliasType tys (TypeArrow ty1 ty2) =
> TypeArrow (expandAliasType tys ty1) (expandAliasType tys ty2)
> expandAliasType _ (TypeSkolem k) = TypeSkolem k
> expandAliasType tys (TypeRecord fs rv)
> expandAliasType _ tsk@(TypeSkolem _) = tsk
> expandAliasType tys (TypeRecord fs rv)
> | isJust rv =
> let (TypeVariable tv) = expandAliasType tys $ TypeVariable $ fromJust rv
> in TypeRecord fs' (Just tv)
> | otherwise =
> TypeRecord fs' Nothing
> where fs' = map (\ (l,ty) -> (l, expandAliasType tys ty)) fs
> where fs' = map (\ (l, ty) -> (l, expandAliasType tys ty)) fs
> normalize :: Type -> Type
> normalize ty = expandAliasType [TypeVariable (occur tv) | tv <- [0..]] ty
> where tvs = zip (nub (filter (>= 0) (typeVars ty))) [0..]
> normalize ty = expandAliasType [TypeVariable (occur tv) | tv <- [0 ..]] ty
> where tvs = zip (nub (filter (>= 0) (typeVars ty))) [0 ..]
> occur tv = fromJust (lookup tv tvs)
\end{verbatim}
......@@ -40,25 +40,24 @@ TODO: The following two imports should be avoided if possible as they make
> xmlBody :: ModuleSummary -> Module -> Doc
> xmlBody modSum (Module mname mimports decls) =
> xmlElement "module" xmlModuleDecl moduleDecl $$
> xmlElement "import" xmlImportDecl importDecl $$
> xmlElement "types" xmlTypeDecl typeDecl $$
> xmlElement "functions" xmlFunctionDecl funcDecl $$
> xmlElement "operators" xmlOperatorDecl operatorDecl $$
> xmlElement "module" xmlModuleDecl moduleDecl $$
> xmlElement "import" xmlImportDecl importDecl $$
> xmlElement "types" xmlTypeDecl typeDecl $$
> xmlElement "functions" xmlFunctionDecl funcDecl $$
> xmlElement "operators" xmlOperatorDecl operatorDecl $$
> xmlElement "translation" xmlTranslationDecl translationDecl
> where
> moduleDecl = [mname]
> importDecl = mimports
> (funcDecl,typeDecl) = splitDecls decls
> operatorDecl = infixDecls modSum
> translationDecl = foldl (qualIDeclId (moduleId modSum)) [] (interface modSum)
> moduleDecl = [mname]
> importDecl = mimports
> (funcDecl,typeDecl) = splitDecls decls
> operatorDecl = infixDecls modSum
> translationDecl = foldl (qualIDeclId (moduleId modSum)) [] (interface modSum)
> xmlModuleDecl :: ModuleIdent -> Doc
> xmlModuleDecl = xmlModuleIdent
> xmlImportDecl :: ModuleIdent -> Doc
> xmlImportDecl mname = xmlElement "module" xmlModuleDecl [mname]
> xmlImportDecl mname = xmlElement "module" xmlModuleDecl [mname]
=========================================================================
T Y P E S
......
......@@ -201,7 +201,7 @@ in the type environment.
> abstractFunAnnots :: ModuleIdent -> String -> [Ident] -> EvalEnv -> EvalEnv
> abstractFunAnnots _ pre fs evEnv = foldr abstractFunAnnot evEnv fs
> where
> where
> abstractFunAnnot f evEnv' = case Map.lookup f evEnv' of
> Just ev -> Map.insert (liftIdent pre f) ev (Map.delete f evEnv')
> Nothing -> evEnv'
......@@ -285,7 +285,7 @@ to the top-level.
> (alts',dss') = unzip $ map liftAlt alts
> liftExpr _ = internalError "Lift.liftExpr"
> liftAlt :: Alt -> (Alt,[Decl])
> liftAlt :: Alt -> (Alt, [Decl])
> liftAlt (Alt p t rhs) = (Alt p t rhs', ds') where (rhs', ds') = liftRhs rhs
\end{verbatim}
......
......@@ -20,7 +20,7 @@ declarations groups as well as function arguments remain unchanged.
> module Transformations.Qual (qual) where
> import Control.Monad (liftM, liftM2, liftM3)
> import qualified Control.Monad.Reader as R
> import qualified Control.Monad.Reader as R (Reader, asks, runReader)
> import Curry.Base.Ident
> import Curry.Syntax
......@@ -39,21 +39,21 @@ declarations groups as well as function arguments remain unchanged.
> type Qual a = a -> R.Reader QualEnv a
> qual :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> [Decl]
> qual m tcEnv tyEnv ds = R.runReader (mapM qualDecl ds)
> qual m tcEnv tyEnv ds = R.runReader (mapM qualDecl ds)
> (QualEnv m tcEnv tyEnv)
> qualDecl :: Qual Decl
> qualDecl i@(InfixDecl _ _ _ _) = return i
> qualDecl (DataDecl p n vs cs) =
> qualDecl (DataDecl p n vs cs) =
> DataDecl p n vs `liftM` mapM qualConstr cs
> qualDecl (NewtypeDecl p n vs nc) =
> qualDecl (NewtypeDecl p n vs nc) =
> NewtypeDecl p n vs `liftM` qualNewConstr nc
> qualDecl (TypeDecl p n vs ty) = TypeDecl p n vs `liftM` qualTypeExpr ty
> qualDecl (TypeSig p fs ty) = TypeSig p fs `liftM` qualTypeExpr ty
> qualDecl e@(EvalAnnot _ _ _) = return e
> qualDecl (FunctionDecl p f eqs) =
> FunctionDecl p f `liftM` mapM qualEqn eqs
> qualDecl (ExternalDecl p c x n ty) =
> qualDecl (ExternalDecl p c x n ty) =
> ExternalDecl p c x n `liftM` qualTypeExpr ty
> qualDecl fe@(FlatExternalDecl _ _) = return fe
> qualDecl (PatternDecl p t rhs) =
......@@ -61,31 +61,32 @@ declarations groups as well as function arguments remain unchanged.
> qualDecl vs@(ExtraVariables _ _) = return vs
> qualConstr :: Qual ConstrDecl
> qualConstr (ConstrDecl p vs n tys) =
> qualConstr (ConstrDecl p vs n tys) =
> ConstrDecl p vs n `liftM` mapM qualTypeExpr tys
> qualConstr (ConOpDecl p vs ty1 op ty2) =
> liftM2 (flip (ConOpDecl p vs) op) (qualTypeExpr ty1) (qualTypeExpr ty2)
> qualNewConstr :: Qual NewConstrDecl
> qualNewConstr (NewConstrDecl p vs n ty) =
> qualNewConstr (NewConstrDecl p vs n ty) =
> NewConstrDecl p vs n `liftM` qualTypeExpr ty
> qualTypeExpr :: Qual TypeExpr
> qualTypeExpr (ConstructorType q tys) =
> liftM2 ConstructorType (qualConstructor q) (mapM qualTypeExpr tys)
> qualTypeExpr v@(VariableType _) = return v
> qualTypeExpr (TupleType tys) =
> qualTypeExpr (TupleType tys) =
> TupleType `liftM` mapM qualTypeExpr tys
> qualTypeExpr (ListType ty) = ListType `liftM` qualTypeExpr ty
> qualTypeExpr (ArrowType ty1 ty2) =
> qualTypeExpr (ArrowType ty1 ty2) =
> liftM2 ArrowType (qualTypeExpr ty1) (qualTypeExpr ty2)
> qualTypeExpr (RecordType fs rty) =
> liftM2 RecordType (mapM qualFieldType fs) (qualRecordType rty)
> where qualFieldType (ls, ty) = do
> ty' <- qualTypeExpr ty
> return (ls, ty')
> qualRecordType Nothing = return Nothing
> qualRecordType (Just v) = Just `liftM` qualTypeExpr v
> where
> qualFieldType (ls, ty) = do
> ty' <- qualTypeExpr ty
> return (ls, ty')
> qualRecordType Nothing = return Nothing
> qualRecordType (Just v) = Just `liftM` qualTypeExpr v
> qualEqn :: Qual Equation
> qualEqn (Equation p lhs rhs) =
......@@ -99,23 +100,25 @@ declarations groups as well as function arguments remain unchanged.
> liftM2 ApLhs (qualLhs lhs) (mapM qualTerm ts)
> qualTerm :: Qual ConstrTerm
> qualTerm l@(LiteralPattern _) = return l
> qualTerm n@(NegativePattern _ _) = return n
> qualTerm v@(VariablePattern _) = return v
> qualTerm (ConstructorPattern c ts) =
> qualTerm l@(LiteralPattern _) = return l
> qualTerm n@(NegativePattern _ _) = return n
> qualTerm v@(VariablePattern _) = return v
> qualTerm (ConstructorPattern c ts) =
> liftM2 ConstructorPattern (qualIdent c) (mapM qualTerm ts)
> qualTerm (InfixPattern t1 op t2) =
> qualTerm (InfixPattern t1 op t2) =
> liftM3 InfixPattern (qualTerm t1) (qualIdent op) (qualTerm t2)
> qualTerm (ParenPattern t) = ParenPattern `liftM` qualTerm t
> qualTerm (TuplePattern p ts) = TuplePattern p `liftM` mapM qualTerm ts
> qualTerm (ListPattern p ts) = ListPattern p `liftM` mapM qualTerm ts
> qualTerm (AsPattern v t) = AsPattern v `liftM` qualTerm t
> qualTerm (LazyPattern p t) = LazyPattern p `liftM` qualTerm t
> qualTerm (FunctionPattern f ts) =
> qualTerm (ParenPattern t) = ParenPattern `liftM` qualTerm t
> qualTerm (TuplePattern p ts) =
> TuplePattern p `liftM` mapM qualTerm ts
> qualTerm (ListPattern p ts) =
> ListPattern p `liftM` mapM qualTerm ts
> qualTerm (AsPattern v t) = AsPattern v `liftM` qualTerm t
> qualTerm (LazyPattern p t) = LazyPattern p `liftM` qualTerm t
> qualTerm (FunctionPattern f ts) =
> liftM2 FunctionPattern (qualIdent f) (mapM qualTerm ts)
> qualTerm (InfixFuncPattern t1 op t2) =
> liftM3 InfixFuncPattern (qualTerm t1) (qualIdent op) (qualTerm t2)
> qualTerm (RecordPattern fs rt) =
> qualTerm (RecordPattern fs rt) =
> liftM2 RecordPattern (mapM qualFieldPattern fs) (qualRecordTerm rt)
> where qualRecordTerm Nothing = return Nothing
> qualRecordTerm (Just v) = Just `liftM` qualTerm v
......@@ -194,7 +197,7 @@ declarations groups as well as function arguments remain unchanged.
> qualIdent :: Qual QualIdent
> qualIdent x = do
> m <- R.asks moduleIdent
> m <- R.asks moduleIdent
> tyEnv <- R.asks valueEnv
> return $ case isQualified x || isGlobal x of
> False -> x
......@@ -208,7 +211,7 @@ declarations groups as well as function arguments remain unchanged.
> qualConstructor :: Qual QualIdent
> qualConstructor x = do
> m <- R.asks moduleIdent
> m <- R.asks moduleIdent
> tcEnv <- R.asks tyConsEnv
> return $ case qualLookupTC x tcEnv of
> [y] -> origName y
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment