AbstractCurry.curry 6.28 KB
Newer Older
Michael Hanus's avatar
Michael Hanus committed
1
2
3
4
5
6
7
8
--------------------------------------------------------------------------------
--- This module contains helper functions for dealing with AbstractCurry. In
--- particular, it contains functions that can read modules from a package and
--- its dependencies with all dependencies available to the Curry frontend.
--------------------------------------------------------------------------------

module CPM.AbstractCurry 
  ( loadPathForPackage
Michael Hanus's avatar
Michael Hanus committed
9
  , readAbstractCurryFromPackagePath
Michael Hanus's avatar
Michael Hanus committed
10
11
12
  , readAbstractCurryFromDeps
  , transformAbstractCurryInDeps 
  , applyModuleRenames
13
  , tcArgsOfType
Michael Hanus's avatar
Michael Hanus committed
14
15
16
  ) where

import Distribution (FrontendTarget (..), FrontendParams (..), defaultParams
Michael Hanus's avatar
Michael Hanus committed
17
18
                    , callFrontendWithParams, setQuiet, setFullPath
                    , sysLibPath, inCurrySubdir, modNameToPath
Michael Hanus's avatar
Michael Hanus committed
19
20
21
22
23
24
25
                    , inCurrySubdirModule, lookupModuleSource)
import List (intercalate, nub)
import FilePath ((</>), (<.>), takeFileName, replaceExtension)
import AbstractCurry.Files (readAbstractCurryFile, writeAbstractCurryFile)
import AbstractCurry.Pretty (showCProg)
import AbstractCurry.Select (imports)
import AbstractCurry.Transform
26
import AbstractCurry.Types
Michael Hanus's avatar
Michael Hanus committed
27
28
import System

Michael Hanus's avatar
Michael Hanus committed
29
import CPM.ErrorLogger
Michael Hanus's avatar
Michael Hanus committed
30
import qualified CPM.PackageCache.Runtime as RuntimeCache
Michael Hanus's avatar
Michael Hanus committed
31
import CPM.Package (Package, loadPackageSpec, sourceDirsOf)
Michael Hanus's avatar
Michael Hanus committed
32
33

--- Returns the load path for a package stored in some directory
Michael Hanus's avatar
Michael Hanus committed
34
--- w.r.t. the dependent packages.
Michael Hanus's avatar
Michael Hanus committed
35
---
Michael Hanus's avatar
Michael Hanus committed
36
37
--- @param - pkg - the package
--- @param - pkgDir - the directory containing this package
Michael Hanus's avatar
Michael Hanus committed
38
39
--- @param - deps - the resolved dependencies of the package
--- @return the full load path for modules in the package or dependent packages
Michael Hanus's avatar
Michael Hanus committed
40
41
42
43
44
loadPathForPackage :: Package -> String -> [Package] -> [String]
loadPathForPackage pkg pkgDir deps =
  (map (pkgDir </>) (sourceDirsOf pkg) ++
  RuntimeCache.dependencyPathsSeparate deps pkgDir)

Michael Hanus's avatar
Michael Hanus committed
45
46
--- Returns the full load path for a package stored in some directory.
---
Michael Hanus's avatar
Michael Hanus committed
47
48
--- @param - pkg - the package
--- @param - pkgDir - the directory containing this package
Michael Hanus's avatar
Michael Hanus committed
49
50
--- @param - deps - the resolved dependencies of the package
--- @return the full load path for modules in the package or dependent packages
Michael Hanus's avatar
Michael Hanus committed
51
52
53
54
55
fullLoadPathForPackage :: Package -> String -> [Package] -> [String]
fullLoadPathForPackage pkg pkgDir deps =
  loadPathForPackage pkg pkgDir deps ++ sysLibPath
  -- here we assume that the system libs are identical for each Curry system

Michael Hanus's avatar
Michael Hanus committed
56
57
58
59
60
--- Reads an AbstractCurry module from a package.
---
--- @param - dir the package's directory
--- @param - deps the resolved dependencies of the package
--- @param - mod the module to read
Michael Hanus's avatar
Michael Hanus committed
61
62
63
64
readAbstractCurryFromPackagePath :: Package -> String -> [Package] -> String
                                 -> IO CurryProg
readAbstractCurryFromPackagePath pkg pkgDir deps modname = do
  let loadPath = fullLoadPathForPackage pkg pkgDir deps
Michael Hanus's avatar
Michael Hanus committed
65
66
  params <- return $ setQuiet True (setFullPath loadPath defaultParams)
  callFrontendWithParams ACY params modname 
Michael Hanus's avatar
Michael Hanus committed
67
68
69
70
  src <- lookupModuleSource loadPath modname
  acyName <- return $ case src of
    Nothing -> error $ "Module not found: " ++ modname
    Just (_, file) -> replaceExtension (inCurrySubdirModule modname file) ".acy"
Michael Hanus's avatar
Michael Hanus committed
71
  readAbstractCurryFile acyName
Michael Hanus's avatar
Michael Hanus committed
72

Michael Hanus's avatar
Michael Hanus committed
73
74
75
76
77
78
79
--- Reads an AbstractCurry module from a package or one of its dependencies.
---
--- @param dir - the package's directory
--- @param deps - the resolved dependencies of the package
--- @param mod - the module to read
readAbstractCurryFromDeps :: String -> [Package] -> String -> IO CurryProg
readAbstractCurryFromDeps pkgDir deps modname = do
Michael Hanus's avatar
Michael Hanus committed
80
81
  pkg <- fromErrorLogger (loadPackageSpec pkgDir)
  let loadPath = fullLoadPathForPackage pkg pkgDir deps
Michael Hanus's avatar
Michael Hanus committed
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
  params <- return $ setQuiet True (setFullPath loadPath defaultParams)
  src <- lookupModuleSource loadPath modname
  sourceFile <- return $ case src of
    Nothing -> error $ "Module not found: " ++ modname
    Just (_, file) -> replaceExtension (inCurrySubdirModule modname file) ".acy"
  callFrontendWithParams ACY params modname
  readAbstractCurryFile sourceFile

--- Applies a transformation function to a module from a package or one of its
--- dependencies and writes the modified module to a file in Curry form.
---
--- @param dir - the package's directory
--- @param deps - the resolved dependencies of the package
--- @param f - the transformation function
--- @param mod - the module to transform
--- @param dest - the destination file for the transformed module
transformAbstractCurryInDeps :: String -> [Package] -> (CurryProg -> CurryProg) 
                             -> String -> String -> IO ()
transformAbstractCurryInDeps pkgDir deps transform modname destFile = do
Michael Hanus's avatar
Michael Hanus committed
101
102
  pkg <- fromErrorLogger (loadPackageSpec pkgDir)
  let loadPath = fullLoadPathForPackage pkg pkgDir deps
Michael Hanus's avatar
Michael Hanus committed
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
  params <- return $ setQuiet True (setFullPath loadPath defaultParams)
  src <- lookupModuleSource loadPath modname
  sourceFile <- return $ case src of
    Nothing -> error $ "Module not found: " ++ modname
    Just (_, file) -> replaceExtension (inCurrySubdirModule modname file) ".acy"
  callFrontendWithParams ACY params modname
  acy <- readAbstractCurryFile sourceFile
  writeFile destFile $ showCProg (transform acy)

--- Renames all references to some modules in a Curry program.
--- 
--- @param mods - a map from old to new module names
--- @param prog - the program to modify
applyModuleRenames :: [(String, String)] -> CurryProg -> CurryProg
applyModuleRenames names prog =
118
119
  updCProg maybeRename (map maybeRename) id id id id id id
           (updQNamesInCProg rnm prog)
Michael Hanus's avatar
Michael Hanus committed
120
121
122
123
124
125
126
127
 where
  maybeRename n = case lookup n names of
    Just n' -> n'
    Nothing -> n
  rnm mn@(mod, n) = case lookup mod names of
    Just mod' -> (mod', n)
    Nothing   -> mn

128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

--- Checks whether a type expression is a type constructor application.
--- If this is the case, return the type constructor and the type arguments.
tcArgsOfType :: CTypeExpr -> Maybe (QName,[CTypeExpr])
tcArgsOfType texp =
  maybe Nothing
        (\tc -> Just (tc, targsOfApply texp))
        (tconOfApply texp)
 where
  tconOfApply te = case te of CTApply (CTCons qn) _ -> Just qn
                              CTApply tc _          -> tconOfApply tc
                              _                     -> Nothing
                                 
  targsOfApply te = case te of
    CTApply (CTCons _) ta -> [ta]
    CTApply tc         ta -> targsOfApply tc ++ [ta]
    _                     -> [] -- should not occur