Commit 230f5299 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Merge remote-tracking branch 'origin/master'

Conflicts:
	src/CompilerEnv.hs
parents 2bc6a0ff 372a9c4b
......@@ -95,7 +95,6 @@ Library
, Imports
, Interfaces
, Modules
, ModuleSummary
, TokenStream
, Transformations
, Transformations.CaseCompletion
......
......@@ -17,11 +17,13 @@ module Base.TypeSubst
import Data.List (nub)
import Base.Messages (internalError)
import Base.Subst
import Base.TopEnv
import Base.Types
import Env.Value (ValueInfo (..))
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import Env.Value (ValueInfo (..))
type TypeSubst = Subst Int Type
......@@ -62,6 +64,20 @@ instance SubstType ValueInfo where
instance SubstType a => SubstType (TopEnv a) where
subst = fmap . subst
-- Expand all type synonyms in a type
expandType :: TCEnv -> Type -> Type
expandType tcEnv (TypeConstructor tc tys) = case qualLookupTC tc tcEnv of
[DataType tc' _ _] -> TypeConstructor tc' tys'
[RenamingType tc' _ _] -> TypeConstructor tc' tys'
[AliasType _ _ ty] -> expandAliasType tys' ty
_ -> internalError $ "Desugar.expandType " ++ show tc
where tys' = map (expandType tcEnv) tys
expandType _ tv@(TypeVariable _) = tv
expandType _ tc@(TypeConstrained _ _) = tc
expandType tcEnv (TypeArrow ty1 ty2) = TypeArrow (expandType tcEnv ty1)
(expandType tcEnv ty2)
expandType _ ts@(TypeSkolem _) = ts
-- The function 'expandAliasType' expands all occurrences of a
-- type synonym in a type. After the expansion we have to reassign the
-- type indices for all type variables. Otherwise, expanding a type
......
......@@ -48,7 +48,7 @@ import Base.Messages (Message, posMessage, internalError)
import Base.SCC
import Base.TopEnv
import Base.Types
import Base.TypeSubst
import Base.TypeSubst hiding (expandType)
import Base.Utils (foldr2)
import Env.TypeConstructor (TCEnv, TypeInfo (..), bindTypeInfo, qualLookupTC)
......
......@@ -15,7 +15,7 @@ module CompilerEnv where
import qualified Data.Map as Map (Map, keys, toList)
import Curry.Base.Ident (ModuleIdent)
import Curry.Base.Ident (ModuleIdent, moduleName)
import Curry.Base.Pretty
import Curry.Base.Span (Span)
import Curry.Syntax
......@@ -62,10 +62,11 @@ initCompilerEnv mid = CompilerEnv
-- |Show the 'CompilerEnv'
showCompilerEnv :: CompilerEnv -> String
showCompilerEnv env = show $ vcat
[ header "Module Identifier " $ textS $ moduleIdent env
[ header "Module Identifier " $ text $ moduleName $ moduleIdent env
, header "FilePath" $ text $ filePath env
, header "Language Extensions" $ text $ show $ extensions env
, header "Interfaces " $ hcat $ punctuate comma $ map textS
, header "Interfaces " $ hcat $ punctuate comma
$ map (text . moduleName)
$ Map.keys $ interfaceEnv env
, header "Module Aliases " $ ppMap $ aliasEnv env
, header "Precedences " $ ppAL $ allLocalBindings $ opPrecEnv env
......@@ -74,7 +75,6 @@ showCompilerEnv env = show $ vcat
]
where
header hdr content = hang (text hdr <+> colon) 4 content
textS = text . show
-- |Pretty print a 'Map'
ppMap :: (Show a, Show b) => Map.Map a b -> Doc
......
......@@ -3,7 +3,7 @@
Description : Computation of export interface
Copyright : (c) 2000 - 2004, Wolfgang Lux
2005 , Martin Engelke
2011 - 2013, Björn Peemöller
2011 - 2016, Björn Peemöller
2015 , Jan Tikovsky
License : OtherLicense
......@@ -75,10 +75,9 @@ infixDecl _ _ _ _ = internalError "Exports.infixDecl: no pattern match"
iInfixDecl :: ModuleIdent -> OpPrecEnv -> QualIdent -> [IDecl] -> [IDecl]
iInfixDecl m pEnv op ds = case qualLookupP op pEnv of
[] -> ds
[PrecInfo _ (OpPrec fix pr)] ->
IInfixDecl NoPos fix pr (qualUnqualify m op) : ds
_ -> internalError "Exports.infixDecl"
[] -> ds
[PrecInfo _ (OpPrec f p)] -> IInfixDecl NoPos f p (qualUnqualify m op) : ds
_ -> internalError "Exports.infixDecl"
-- Data types and renaming types whose constructors and field labels are
-- not exported are exported as abstract types, i.e., their constructors
......@@ -91,14 +90,14 @@ typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]
typeDecl _ _ (Export _) ds = ds
typeDecl m tcEnv (ExportTypeWith tc xs) ds = case qualLookupTC tc tcEnv of
[DataType tc' n cs]
| null xs -> iTypeDecl IDataDecl m tc' n [] [] : ds
| null xs -> iTypeDecl IDataDecl m tc' n [] [] : ds
| otherwise -> iTypeDecl IDataDecl m tc' n cs' hs : ds
where hs = filter (`notElem` xs) (csIds ++ ls)
cs' = map (constrDecl m (drop n identSupply)) cs
ls = nub (concatMap recordLabels cs')
csIds = map constrIdent cs
[RenamingType tc' n c]
| null xs -> iTypeDecl IDataDecl m tc' n [] [] : ds
| null xs -> iTypeDecl IDataDecl m tc' n [] [] : ds
| otherwise -> iTypeDecl INewtypeDecl m tc' n nc hs : ds
where hs = filter (`notElem` xs) (cId : ls)
nc = newConstrDecl m (drop n identSupply) c
......@@ -117,28 +116,22 @@ iTypeDecl f m tc n x hs = f NoPos (qualUnqualify m tc) (take n identSupply) x hs
constrDecl :: ModuleIdent -> [Ident] -> DataConstr -> ConstrDecl
constrDecl m tvs (DataConstr c n [ty1,ty2])
| isInfixOp c = ConOpDecl NoPos evs (fromQualType m ty1) c (fromQualType m ty2)
where evs = take n tvs
constrDecl m tvs (DataConstr c n tys) = ConstrDecl NoPos evs c tys'
where evs = take n tvs
tys' = map (fromQualType m) tys
constrDecl m tvs (RecordConstr c n ls tys) = RecordDecl NoPos evs c fs
where
evs = take n tvs
tys' = map (fromQualType m) tys
fs = zipWith (FieldDecl NoPos . return) ls tys'
| isInfixOp c
= ConOpDecl NoPos (take n tvs) (fromQualType m ty1) c (fromQualType m ty2)
constrDecl m tvs (DataConstr c n tys)
= ConstrDecl NoPos (take n tvs) c (map (fromQualType m) tys)
constrDecl m tvs (RecordConstr c n ls tys)
= RecordDecl NoPos (take n tvs) c
$ zipWith (FieldDecl NoPos . return) ls (map (fromQualType m) tys)
newConstrDecl :: ModuleIdent -> [Ident] -> DataConstr -> NewConstrDecl
newConstrDecl m tvs (DataConstr c n tys) = NewConstrDecl NoPos evs c ty'
where evs = take n tvs
ty' = fromQualType m (head tys)
newConstrDecl m tvs (DataConstr c n tys)
= NewConstrDecl NoPos (take n tvs) c (fromQualType m (head tys))
newConstrDecl m tvs (RecordConstr c n ls tys)
= NewRecordDecl NoPos evs c (head ls,ty')
where evs = take n tvs
ty' = fromQualType m (head tys)
= NewRecordDecl NoPos (take n tvs) c (head ls, fromQualType m (head tys))
funDecl :: ModuleIdent -> ValueEnv -> Export -> [IDecl] -> [IDecl]
funDecl m tyEnv (Export f) ds = case qualLookupValue f tyEnv of
funDecl m tyEnv (Export f) ds = case qualLookupValue f tyEnv of
[Value _ a (ForAll _ ty)] ->
IFunctionDecl NoPos (qualUnqualify m f) a (fromQualType m ty) : ds
_ -> internalError $ "Exports.funDecl: " ++ show f
......@@ -164,37 +157,35 @@ funDecl _ _ _ _ = internalError "Exports.funDecl: no pattern match"
-- the interface for module @C@ will import module @A@ but not module @B@.
usedModules :: [IDecl] -> [ModuleIdent]
usedModules ds = nub' (catMaybes (map qidModule (foldr identsDecl [] ds)))
usedModules ds = nub' (catMaybes (map qidModule (foldr idsDecl [] ds)))
where nub' = Set.toList . Set.fromList
identsDecl :: IDecl -> [QualIdent] -> [QualIdent]
identsDecl (IDataDecl _ tc _ cs _) xs =
tc : foldr identsConstrDecl xs cs
identsDecl (INewtypeDecl _ tc _ nc _) xs = tc : identsNewConstrDecl nc xs
identsDecl (ITypeDecl _ tc _ ty) xs = tc : identsType ty xs
identsDecl (IFunctionDecl _ f _ ty) xs = f : identsType ty xs
identsDecl _ _ = internalError "Exports.identsDecl: no pattern match"
idsDecl :: IDecl -> [QualIdent] -> [QualIdent]
idsDecl (IDataDecl _ tc _ cs _) xs = tc : foldr idsConstrDecl xs cs
idsDecl (INewtypeDecl _ tc _ nc _) xs = tc : identsNewConstrDecl nc xs
idsDecl (ITypeDecl _ tc _ ty) xs = tc : idsType ty xs
idsDecl (IFunctionDecl _ f _ ty) xs = f : idsType ty xs
idsDecl _ _ = internalError "Exports.idsDecl: no pattern match"
identsConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
identsConstrDecl (ConstrDecl _ _ _ tys) xs = foldr identsType xs tys
identsConstrDecl (ConOpDecl _ _ ty1 _ ty2) xs =
identsType ty1 (identsType ty2 xs)
identsConstrDecl (RecordDecl _ _ _ fs) xs = foldr identsFieldDecl xs fs
idsConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
idsConstrDecl (ConstrDecl _ _ _ tys) xs = foldr idsType xs tys
idsConstrDecl (ConOpDecl _ _ ty1 _ ty2) xs = idsType ty1 (idsType ty2 xs)
idsConstrDecl (RecordDecl _ _ _ fs) xs = foldr identsFieldDecl xs fs
identsFieldDecl :: FieldDecl -> [QualIdent] -> [QualIdent]
identsFieldDecl (FieldDecl _ _ ty) xs = identsType ty xs
identsFieldDecl (FieldDecl _ _ ty) xs = idsType ty xs
identsNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
identsNewConstrDecl (NewConstrDecl _ _ _ ty) xs = identsType ty xs
identsNewConstrDecl (NewRecordDecl _ _ _ (_,ty)) xs = identsType ty xs
identsNewConstrDecl (NewConstrDecl _ _ _ ty) xs = idsType ty xs
identsNewConstrDecl (NewRecordDecl _ _ _ (_,ty)) xs = idsType ty xs
identsType :: TypeExpr -> [QualIdent] -> [QualIdent]
identsType (ConstructorType tc tys) xs = tc : foldr identsType xs tys
identsType (VariableType _) xs = xs
identsType (TupleType tys) xs = foldr identsType xs tys
identsType (ListType ty) xs = identsType ty xs
identsType (ArrowType ty1 ty2) xs = identsType ty1 (identsType ty2 xs)
identsType (ParenType ty) xs = identsType ty xs
idsType :: TypeExpr -> [QualIdent] -> [QualIdent]
idsType (ConstructorType tc tys) xs = tc : foldr idsType xs tys
idsType (VariableType _) xs = xs
idsType (TupleType tys) xs = foldr idsType xs tys
idsType (ListType ty) xs = idsType ty xs
idsType (ArrowType ty1 ty2) xs = idsType ty1 (idsType ty2 xs)
idsType (ParenType ty) xs = idsType ty xs
-- After the interface declarations have been computed, the compiler
-- eventually must add hidden (data) type declarations to the interface
......@@ -211,45 +202,40 @@ hiddenTypeDecl m tcEnv tc = case qualLookupTC (qualQualify m tc) tcEnv of
hiddenTypes :: ModuleIdent -> [IDecl] -> [QualIdent]
hiddenTypes m ds = [tc | tc <- Set.toList tcs, hidden tc]
where tcs = foldr Set.delete (Set.fromList $ usedTypes ds)
(definedTypes ds)
hidden tc = not (isQualified tc) || qidModule tc /= Just m
where
tcs = foldr Set.delete (Set.fromList $ usedTypes ds) (definedTypes ds)
hidden tc = not (isQualified tc) || qidModule tc /= Just m
usedTypes :: [IDecl] -> [QualIdent]
usedTypes ds = foldr usedTypesDecl [] ds
usedTypesDecl :: IDecl -> [QualIdent] -> [QualIdent]
usedTypesDecl (IDataDecl _ _ _ cs _) tcs =
foldr usedTypesConstrDecl tcs cs
usedTypesDecl (INewtypeDecl _ _ _ nc _) tcs = usedTypesNewConstrDecl nc tcs
usedTypesDecl (ITypeDecl _ _ _ ty ) tcs = usedTypesType ty tcs
usedTypesDecl (IFunctionDecl _ _ _ ty ) tcs = usedTypesType ty tcs
usedTypesDecl _ _ = internalError
"Exports.usedTypesDecl: no pattern match" -- TODO
usedTypesConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
usedTypesConstrDecl (ConstrDecl _ _ _ tys) tcs =
foldr usedTypesType tcs tys
usedTypesConstrDecl (ConOpDecl _ _ ty1 _ ty2) tcs =
usedTypesType ty1 (usedTypesType ty2 tcs)
usedTypesConstrDecl (RecordDecl _ _ _ fs) tcs =
foldr usedTypesFieldDecl tcs fs
usedTypesFieldDecl :: FieldDecl -> [QualIdent] -> [QualIdent]
usedTypesFieldDecl (FieldDecl _ _ ty) tcs = usedTypesType ty tcs
usedTypesNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
usedTypesNewConstrDecl (NewConstrDecl _ _ _ ty) tcs = usedTypesType ty tcs
usedTypesNewConstrDecl (NewRecordDecl _ _ _ (_,ty)) tcs = usedTypesType ty tcs
usedTypesType :: TypeExpr -> [QualIdent] -> [QualIdent]
usedTypesType (ConstructorType tc tys) tcs = tc : foldr usedTypesType tcs tys
usedTypesType (VariableType _) tcs = tcs
usedTypesType (TupleType tys) tcs = foldr usedTypesType tcs tys
usedTypesType (ListType ty) tcs = usedTypesType ty tcs
usedTypesType (ArrowType ty1 ty2) tcs =
usedTypesType ty1 (usedTypesType ty2 tcs)
usedTypesType (ParenType ty) tcs = usedTypesType ty tcs
usedTypes ds = foldr utDecl [] ds
utDecl :: IDecl -> [QualIdent] -> [QualIdent]
utDecl (IDataDecl _ _ _ cs _) tcs = foldr utConstrDecl tcs cs
utDecl (INewtypeDecl _ _ _ nc _) tcs = utNewConstrDecl nc tcs
utDecl (ITypeDecl _ _ _ ty ) tcs = utType ty tcs
utDecl (IFunctionDecl _ _ _ ty ) tcs = utType ty tcs
utDecl d _ = internalError
$ "Exports.utDecl: " ++ show d
utConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
utConstrDecl (ConstrDecl _ _ _ tys) tcs = foldr utType tcs tys
utConstrDecl (ConOpDecl _ _ ty1 _ ty2) tcs = utType ty1 (utType ty2 tcs)
utConstrDecl (RecordDecl _ _ _ fs) tcs = foldr utFieldDecl tcs fs
utFieldDecl :: FieldDecl -> [QualIdent] -> [QualIdent]
utFieldDecl (FieldDecl _ _ ty) tcs = utType ty tcs
utNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
utNewConstrDecl (NewConstrDecl _ _ _ ty) tcs = utType ty tcs
utNewConstrDecl (NewRecordDecl _ _ _ (_,ty)) tcs = utType ty tcs
utType :: TypeExpr -> [QualIdent] -> [QualIdent]
utType (ConstructorType tc tys) tcs = tc : foldr utType tcs tys
utType (VariableType _) tcs = tcs
utType (TupleType tys) tcs = foldr utType tcs tys
utType (ListType ty) tcs = utType ty tcs
utType (ArrowType ty1 ty2) tcs = utType ty1 (utType ty2 tcs)
utType (ParenType ty) tcs = utType ty tcs
definedTypes :: [IDecl] -> [QualIdent]
definedTypes ds = foldr definedType [] ds
......
......@@ -12,16 +12,15 @@
-}
module Generators where
import qualified Curry.AbstractCurry as AC (CurryProg)
import qualified Curry.ExtendedFlat.Type as EF (Prog)
import qualified Curry.Syntax as CS (Module)
import qualified Curry.AbstractCurry as AC (CurryProg)
import qualified Curry.ExtendedFlat.Type as EF (Prog)
import qualified Curry.Syntax as CS (Module, Interface)
import qualified Generators.GenAbstractCurry as GAC
import qualified Generators.GenFlatCurry as GFC
import qualified Generators.GenAbstractCurry as GAC (genAbstractCurry)
import qualified Generators.GenFlatCurry as GFC (genFlatCurry, genFlatInterface)
import CompilerEnv
import IL (Module)
import ModuleSummary
import CompilerEnv (CompilerEnv (..))
import qualified IL (Module)
-- |Generate typed AbstractCurry
genTypedAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
......@@ -32,11 +31,9 @@ genUntypedAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
genUntypedAbstractCurry = GAC.genAbstractCurry True
-- |Generate FlatCurry
genFlatCurry :: ModuleSummary -> CompilerEnv -> IL.Module -> EF.Prog
genFlatCurry ms env = GFC.genFlatCurry ms
(interfaceEnv env) (valueEnv env) (tyConsEnv env)
genFlatCurry :: CompilerEnv -> CS.Module -> IL.Module -> EF.Prog
genFlatCurry = GFC.genFlatCurry
-- |Generate a FlatCurry interface
genFlatInterface :: ModuleSummary -> CompilerEnv -> IL.Module -> EF.Prog
genFlatInterface ms env = GFC.genFlatInterface ms
(interfaceEnv env) (valueEnv env) (tyConsEnv env)
genFlatInterface :: CompilerEnv -> CS.Interface -> CS.Module -> IL.Module -> EF.Prog
genFlatInterface = GFC.genFlatInterface
This diff is collapsed.
......@@ -45,10 +45,10 @@ ppModule (Module m is ds) = sepByBlankLine
[ppHeader m, vcat (map ppImport is), sepByBlankLine (map ppDecl ds)]
ppHeader :: ModuleIdent -> Doc
ppHeader m = text "module" <+> text (show m) <+> text "where"
ppHeader m = text "module" <+> text (moduleName m) <+> text "where"
ppImport :: ModuleIdent -> Doc
ppImport m = text "import" <+> text (show m)
ppImport m = text "import" <+> text (moduleName m)
ppDecl :: Decl -> Doc
ppDecl (DataDecl tc n cs) = sep $
......
{- |
Module : $Header$
Description : Summarized information of a module
Copyright : (c) 2005, Martin Engelke (men@informatik.uni-kiel.de)
2015, Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
Generates a record containing extracted and prepared data from a
'Curry.Syntax.Module'.
-}
module ModuleSummary (ModuleSummary (..), summarizeModule) where
import Data.Maybe (fromMaybe)
import Curry.Base.Ident
import Curry.Syntax
import Base.Messages (internalError)
import Base.Types
import Env.OpPrec (mkPrec)
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
-- |A record containing data for a module 'm'
data ModuleSummary = ModuleSummary
{ moduleId :: ModuleIdent -- ^The name of 'm'
, interface :: [IDecl] -- ^all exported declarations in 'm'
-- (including exported imports)
, exports :: [Export] -- ^The export list extracted from 'm'
, imports :: [IImportDecl] -- ^imports
, infixDecls :: [IDecl] -- ^Interfaces of all infix declarations in 'm'
, typeSynonyms :: [IDecl] -- ^Interfaces of all type synonyms in 'm'
} deriving Show
-- |Return a 'ModuleSummary' for a module, its corresponding
-- table of type constructors and its interface
summarizeModule :: TCEnv -> Interface -> Module -> ModuleSummary
summarizeModule tcEnv (Interface iid _ idecls) (Module _ mid mExp imps decls)
| iid == mid = ModuleSummary
{ moduleId = mid
, interface = idecls
, exports = maybe [] (\ (Exporting _ exps) -> exps) mExp
, imports = genImports imps
, infixDecls = genInfixDecls mid decls
, typeSynonyms = genTypeSyns tcEnv mid decls
}
| otherwise = internalError $
"Interface " ++ show iid ++ " does not match module " ++ show mid
-- |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
-- |Generate interface infix declarations in the module
genInfixDecls :: ModuleIdent -> [Decl] -> [IDecl]
genInfixDecls mident decls = concatMap genInfixDecl decls
where
genInfixDecl :: Decl -> [IDecl]
genInfixDecl (InfixDecl pos spec mPrec idents)
= map (IInfixDecl pos spec (mkPrec mPrec) . qualifyWith mident) idents
genInfixDecl _ = []
-- ---------------------------------------------------------------------------
-- |Generate interface declarations for all type synonyms in the module.
genTypeSyns :: TCEnv -> ModuleIdent -> [Decl] -> [IDecl]
genTypeSyns tcEnv mident decls
= concatMap (genTypeSynDecl mident tcEnv) $ filter isTypeSyn decls
isTypeSyn :: Decl -> Bool
isTypeSyn (TypeDecl _ _ _ _) = True
isTypeSyn _ = False
--
genTypeSynDecl :: ModuleIdent -> TCEnv -> Decl -> [IDecl]
genTypeSynDecl mid tcEnv (TypeDecl p i vs ty)
= [ITypeDecl p (qualifyWith mid i) vs (modifyTypeExpr tcEnv ty)]
genTypeSynDecl _ _ _ = []
--
modifyTypeExpr :: TCEnv -> TypeExpr -> TypeExpr
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 (ParenType ty) = modifyTypeExpr tcEnv ty
--
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 tys)
= ConstructorType qid $ map (genTypeSynDeref its) tys
genTypeSynDeref its (TypeArrow ty1 ty2)
= ArrowType (genTypeSynDeref its ty1) (genTypeSynDeref its ty2)
genTypeSynDeref _ (TypeConstrained _ _) = internalError
"ModuleSummary.genTypeSynDeref: illegal constrained type occured"
genTypeSynDeref _ (TypeSkolem _) = internalError
"ModuleSummary.genTypeSynDeref: illegal skolem type occured"
--
lookupTCId :: QualIdent -> TCEnv -> Maybe QualIdent
lookupTCId qident tcEnv = case qualLookupTC qident tcEnv of
[DataType qid _ _] -> Just qid
[RenamingType qid _ _] -> Just qid
[AliasType qid _ _] -> Just qid
_ -> Nothing
......@@ -60,7 +60,6 @@ import Generators
import Html.CurryHtml (source2html)
import Imports
import Interfaces (loadInterfaces)
import ModuleSummary
import TokenStream (showTokenStream)
import Transformations
......@@ -94,9 +93,7 @@ compileModule opts m fn = do
writeInterface opts (fst mdl') intf
when withFlat $ do
(env2, il) <- transModule opts qmdl
-- generate target code
let modSum = summarizeModule (tyConsEnv env2) intf (snd qmdl)
writeFlat opts env2 modSum il
writeFlat opts env2 intf (snd qmdl) il
where
withFlat = any (`elem` optTargetTypes opts) [FlatCurry, ExtendedFlatCurry]
......@@ -306,18 +303,18 @@ matchInterface ifn i = do
Left _ -> hClose hdl >> return False
Right i' -> return (i `intfEquiv` fixInterface i')
writeFlat :: Options -> CompilerEnv -> ModuleSummary -> IL.Module -> CYIO ()
writeFlat opts env modSum il = do
writeFlat :: Options -> CompilerEnv -> CS.Interface -> CS.Module -> IL.Module -> CYIO ()
writeFlat opts env intf mdl il = do
when (extTarget || fcyTarget) $ do
writeFlatCurry opts env modSum il
writeFlatIntf opts env modSum il
writeFlatCurry opts env mdl il
writeFlatIntf opts env intf mdl il
where
extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
fcyTarget = FlatCurry `elem` optTargetTypes opts
-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry :: Options -> CompilerEnv -> ModuleSummary -> IL.Module -> CYIO ()
writeFlatCurry opts env modSum il = do
writeFlatCurry :: Options -> CompilerEnv -> CS.Module -> IL.Module -> CYIO ()
writeFlatCurry opts env mdl il = do
(_, fc) <- dumpWith opts show EF.ppProg DumpFlatCurry (env, prog)
when extTarget $ liftIO
$ EF.writeExtendedFlat (useSubDir $ extFlatName (filePath env)) fc
......@@ -327,23 +324,23 @@ writeFlatCurry opts env modSum il = do
extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
fcyTarget = FlatCurry `elem` optTargetTypes opts
useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
prog = genFlatCurry modSum env il
prog = genFlatCurry env mdl il
writeFlatIntf :: Options -> CompilerEnv -> ModuleSummary -> IL.Module -> CYIO ()
writeFlatIntf opts env modSum il
writeFlatIntf :: Options -> CompilerEnv -> CS.Interface -> CS.Module -> IL.Module -> CYIO ()
writeFlatIntf opts env intf mdl il
| not (optInterface opts) = return ()
| optForce opts = outputInterface
| otherwise = do
mfint <- liftIO $ EF.readFlatInterface targetFile
let oldInterface = fromMaybe emptyIntf mfint
when (mfint == mfint) $ return () -- necessary to close file -- TODO
unless (oldInterface `eqInterface` intf) $ outputInterface
unless (oldInterface `eqInterface` fint) $ outputInterface
where
targetFile = flatIntName (filePath env)
emptyIntf = EF.Prog "" [] [] [] []
intf = genFlatInterface modSum env il
fint = genFlatInterface env intf mdl il
useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
outputInterface = liftIO $ EF.writeFlatCurry (useSubDir targetFile) intf
outputInterface = liftIO $ EF.writeFlatCurry (useSubDir targetFile) fint
writeAbstractCurry :: Options -> CompEnv CS.Module -> CYIO ()
writeAbstractCurry opts (env, mdl) = do
......
......@@ -81,7 +81,7 @@ import Base.Expr
import Base.CurryTypes (toType, fromType)
import Base.Messages (internalError)
import Base.Types
import Base.TypeSubst (expandAliasType)
import Base.TypeSubst (expandType)
import Base.Typing
import Base.Utils (mapAccumM, concatMapM)
......@@ -1012,20 +1012,6 @@ instType (ForAllExist _ _ ty) = inst ty
inst (TypeArrow ty1 ty2) = TypeArrow (inst ty1) (inst ty2)
inst ty' = ty'
-- Expand all type synonyms in a type
expandType :: TCEnv -> Type -> Type
expandType tcEnv (TypeConstructor tc tys) = case qualLookupTC tc tcEnv of
[DataType tc' _ _] -> TypeConstructor tc' tys'
[RenamingType tc' _ _] -> TypeConstructor tc' tys'
[AliasType _ _ ty] -> expandAliasType tys' ty
_ -> internalError $ "Desugar.expandType " ++ show tc
where tys' = map (expandType tcEnv) tys
expandType _ tv@(TypeVariable _) = tv
expandType _ tc@(TypeConstrained _ _) = tc
expandType tcEnv (TypeArrow ty1 ty2) = TypeArrow (expandType tcEnv ty1)
(expandType tcEnv ty2)
expandType _ ts@(TypeSkolem _) = ts
-- Retrieve all constructors of a type
constructors :: QualIdent -> DsM [DataConstr]
constructors c = getTyConsEnv >>= \tcEnv -> return $
......
......@@ -580,7 +580,7 @@ negateFloat :: Float -> Float