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