Commit 589bb685 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Formatting

parent d199ce8f
......@@ -209,36 +209,30 @@ environment.}
> exprType _ (EnumFromTo _ _) = return (listType intType)
> exprType _ (EnumFromThenTo _ _ _) = return (listType intType)
> exprType tyEnv (UnaryMinus _ e) = exprType tyEnv e
> exprType tyEnv (Apply e1 e2) =
> do
> exprType tyEnv (Apply e1 e2) = do
> (ty1,ty2) <- exprType tyEnv e1 >>= unifyArrow
> exprType tyEnv e2 >>= unify ty1
> return ty2
> exprType tyEnv (InfixApply e1 op e2) =
> do
> exprType tyEnv (InfixApply e1 op e2) = do
> (ty1,ty2,ty3) <- exprType tyEnv (infixOp op) >>= unifyArrow2
> exprType tyEnv e1 >>= unify ty1
> exprType tyEnv e2 >>= unify ty2
> return ty3
> exprType tyEnv (LeftSection e op) =
> do
> exprType tyEnv (LeftSection e op) = do
> (ty1,ty2,ty3) <- exprType tyEnv (infixOp op) >>= unifyArrow2
> exprType tyEnv e >>= unify ty1
> return (TypeArrow ty2 ty3)
> exprType tyEnv (RightSection op e) =
> do
> exprType tyEnv (RightSection op e) = do
> (ty1,ty2,ty3) <- exprType tyEnv (infixOp op) >>= unifyArrow2
> exprType tyEnv e >>= unify ty2
> return (TypeArrow ty1 ty3)
> exprType tyEnv (Lambda _ args e) =
> do
> exprType tyEnv (Lambda _ args e) = do
> tys <- mapM (argType tyEnv) args
> ty <- exprType tyEnv e
> return (foldr TypeArrow ty tys)
> exprType tyEnv (Let _ e) = exprType tyEnv e
> exprType tyEnv (Do _ e) = exprType tyEnv e
> exprType tyEnv (IfThenElse _ e1 e2 e3) =
> do
> exprType tyEnv (IfThenElse _ e1 e2 e3) = do
> exprType tyEnv e1 >>= unify boolType
> ty2 <- exprType tyEnv e2
> ty3 <- exprType tyEnv e3
......@@ -248,19 +242,16 @@ environment.}
> where altType ty [] = return ty
> altType ty (Alt _ _ rhs:alts1) =
> rhsType tyEnv rhs >>= unify ty >> altType ty alts1
> exprType tyEnv (RecordConstr fs) =
> do
> exprType tyEnv (RecordConstr fs) = do
> tys <- mapM (fieldExprType tyEnv) fs
> return (TypeRecord tys Nothing)
> exprType tyEnv (RecordSelection r l) =
> do
> exprType tyEnv (RecordSelection r l) = do
> lty <- instUniv (labelType l tyEnv)
> rty <- exprType tyEnv r
> (TypeVariable i) <- freshTypeVar
> unify rty (TypeRecord [(l,lty)] (Just i))
> return lty
> exprType tyEnv (RecordUpdate fs r) =
> do
> exprType tyEnv (RecordUpdate fs r) = do
> tys <- mapM (fieldExprType tyEnv) fs
> rty <- exprType tyEnv r
> (TypeVariable i) <- freshTypeVar
......@@ -275,8 +266,7 @@ environment.}
> exprType tyEnv e >>= unify ty >> condExprType ty es1
> fieldExprType :: ValueEnv -> Field Expression -> TyState (Ident,Type)
> fieldExprType tyEnv (Field _ l e) =
> do
> fieldExprType tyEnv (Field _ l e) = do
> lty <- instUniv (labelType l tyEnv)
> ty <- exprType tyEnv e
> unify lty ty
......@@ -292,8 +282,7 @@ offsets here.
> freshTypeVar = liftM TypeVariable $ S.lift (S.modify succ >> S.get)
> instType :: Int -> Type -> TyState Type
> instType n ty =
> do
> instType n ty = do
> tys <- sequence (replicate n freshTypeVar)
> return (expandAliasType tys ty)
......@@ -318,8 +307,7 @@ checker.
> unifyList tys1 tys2 = sequence_ (zipWith unify tys1 tys2)
> unifyArrow :: Type -> TyState (Type,Type)
> unifyArrow ty =
> do
> unifyArrow ty = do
> theta <- S.get
> case subst theta ty of
> TypeVariable tv
......
......@@ -15,7 +15,7 @@
-}
module CompilerOpts
( Options (..), CymakeMode (..), Verbosity (..), TargetType (..)
, Extension (..), DumpLevel (..), defaultOptions, compilerOpts, usage
, Extension (..), DumpLevel (..), defaultOptions, getCompilerOpts, usage
) where
import Data.List (intercalate, nub)
......@@ -259,7 +259,7 @@ checkOpts opts files
| isJust (optOutput opts) && length files > 1
= ["cannot specify -o with multiple targets"]
| not $ null unknownExtensions
= ["Unknown language extension(s): " ++ intercalate ", " unknownExtensions]
= ["unknown language extension(s): " ++ intercalate ", " unknownExtensions]
| otherwise
= []
where unknownExtensions = [ e | UnknownExtension e <- optExtensions opts ]
......@@ -267,11 +267,11 @@ checkOpts opts files
-- |Print the usage information of the command line tool.
usage :: String -> String
usage prog = usageInfo header options
where header = "usage: " ++ prog ++ " [OPTION] ... MODULE ..."
where header = "usage: " ++ prog ++ " [OPTION] ... MODULES ..."
-- |Retrieve the compiler 'Options'
compilerOpts :: IO (String, Options, [String], [String])
compilerOpts = do
getCompilerOpts :: IO (String, Options, [String], [String])
getCompilerOpts = do
args <- getArgs
prog <- getProgName
let (opts, files, errs) = parseOpts args
......
......@@ -15,7 +15,6 @@ module ModuleSummary (ModuleSummary (..), summarizeModule) where
import Data.Maybe (fromMaybe)
import Curry.Base.Position
import Curry.Base.Ident
import Curry.Syntax
......@@ -54,9 +53,10 @@ summarizeModule tcEnv (Interface iid _ idecls) (Module mid mExp imps decls)
-- |Generate interface import declarations
genImports :: [ImportDecl] -> [IImportDecl]
genImports = map snd . foldr addImport []
where addImport (ImportDecl pos mid _ _ _) imps = case lookup mid imps of
Nothing -> (mid, IImportDecl pos mid) : imps
Just _ -> imps
where
addImport (ImportDecl pos mid _ _ _) imps = case lookup mid imps of
Nothing -> (mid, IImportDecl pos mid) : imps
Just _ -> imps
-- |Generate interface infix declarations in the module
genInfixDecls :: ModuleIdent -> [Decl] -> [IDecl]
......@@ -82,52 +82,41 @@ isTypeSyn _ = False
--
genTypeSynDecl :: ModuleIdent -> TCEnv -> Decl -> [IDecl]
genTypeSynDecl mid tcEnv (TypeDecl pos ident params texpr)
= [genTypeDecl pos mid ident params tcEnv texpr]
genTypeSynDecl mid tcEnv (TypeDecl p i vs ty)
= [ITypeDecl p (qualifyWith mid i) vs (modifyTypeExpr tcEnv ty)]
genTypeSynDecl _ _ _
= []
--
genTypeDecl :: Position -> ModuleIdent -> Ident -> [Ident] -> TCEnv
-> TypeExpr -> IDecl
genTypeDecl pos mid ident params tcEnv texpr
= ITypeDecl pos (qualifyWith mid ident) params (modifyTypeExpr tcEnv texpr)
--
modifyTypeExpr :: TCEnv -> TypeExpr -> TypeExpr
modifyTypeExpr tcEnv (ConstructorType qident typeexprs)
= case qualLookupTC qident tcEnv of
[AliasType _ arity rhstype]
-> modifyTypeExpr tcEnv
(genTypeSynDeref (zip [0 .. arity - 1] typeexprs) rhstype)
_ -> ConstructorType (fromMaybe qident (lookupTCId qident tcEnv))
(map (modifyTypeExpr tcEnv) typeexprs)
modifyTypeExpr _ (VariableType ident)
= VariableType ident
modifyTypeExpr tcEnv (ArrowType type1 type2)
= ArrowType (modifyTypeExpr tcEnv type1) (modifyTypeExpr tcEnv type2)
modifyTypeExpr tcEnv (TupleType typeexprs)
| null typeexprs
= ConstructorType qUnitId []
| otherwise
= ConstructorType (qTupleId $ length typeexprs)
(map (modifyTypeExpr tcEnv) typeexprs)
modifyTypeExpr tcEnv (ListType typeexpr)
= ConstructorType (qualify listId) [(modifyTypeExpr tcEnv typeexpr)]
modifyTypeExpr tcEnv (RecordType fields rtype)
modifyTypeExpr tcEnv (ConstructorType q tys) = case qualLookupTC q tcEnv of
[AliasType _ ar ty] -> modifyTypeExpr tcEnv
(genTypeSynDeref (zip [0 .. ar - 1] tys) ty)
_ -> ConstructorType (fromMaybe q (lookupTCId q tcEnv))
(map (modifyTypeExpr tcEnv) tys)
modifyTypeExpr _ v@(VariableType _) = v
modifyTypeExpr tcEnv (ArrowType ty1 ty2)
= ArrowType (modifyTypeExpr tcEnv ty1) (modifyTypeExpr tcEnv ty2)
modifyTypeExpr tcEnv (TupleType tys)
| null tys = ConstructorType qUnitId []
| otherwise = ConstructorType (qTupleId $ length tys)
(map (modifyTypeExpr tcEnv) tys)
modifyTypeExpr tcEnv (ListType ty)
= ConstructorType (qualify listId) [modifyTypeExpr tcEnv ty]
modifyTypeExpr tcEnv (RecordType fields mty)
= RecordType
(map (\ (labs, texpr) -> (labs, (modifyTypeExpr tcEnv texpr))) fields)
(maybe Nothing (Just . modifyTypeExpr tcEnv) rtype)
(map (\ (lbls, lty) -> (lbls, modifyTypeExpr tcEnv lty)) fields)
(maybe Nothing (Just . modifyTypeExpr tcEnv) mty)
--
genTypeSynDeref :: [(Int, TypeExpr)] -> Type -> TypeExpr
genTypeSynDeref its (TypeVariable i) = case lookup i its of
Nothing -> internalError "ModuleSummary.genTypeSynDeref: unkown type var index"
Just te -> te
genTypeSynDeref its (TypeConstructor qid tyexps)
= ConstructorType qid $ map (genTypeSynDeref its) tyexps
genTypeSynDeref its (TypeArrow type1 type2)
= ArrowType (genTypeSynDeref its type1) (genTypeSynDeref its type2)
genTypeSynDeref its (TypeConstructor qid tys)
= ConstructorType qid $ map (genTypeSynDeref its) tys
genTypeSynDeref its (TypeArrow ty1 ty2)
= ArrowType (genTypeSynDeref its ty1) (genTypeSynDeref its ty2)
genTypeSynDeref its (TypeRecord fields ri)
= RecordType
(map (\ (lab, texpr) -> ([lab], genTypeSynDeref its texpr)) fields)
......
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