1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module LambdaCube.Compiler.Driver
( module LambdaCube.Compiler.Driver
, Backend(..)
, Pipeline
, Infos
, showRange
, ErrorMsg(..)
, Exp
) where
import Data.List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Except
import Control.Monad.Identity
import Control.DeepSeq
import Control.Monad.Catch
import Control.Exception hiding (catch, bracket, finally, mask)
import Control.Arrow hiding ((<+>))
import System.Directory
import System.FilePath
import Debug.Trace
import LambdaCube.Compiler.Pretty hiding ((</>))
import LambdaCube.Compiler.Infer (Info, Infos, ErrorMsg(..), showRange, PolyEnv(..), Export(..), ModuleR(..), ErrorT, throwErrorTCM, parseLC, joinPolyEnvs, inference_)
import LambdaCube.Compiler.CGExp (Exp, toExp, outputType)
import IR
import qualified LambdaCube.Compiler.CoreToIR as IR
type EName = String
type MName = String
type Modules = Map FilePath (Either Doc PolyEnv)
type ModuleFetcher m = MName -> m (FilePath, String)
newtype MMT m a = MMT { runMMT :: ReaderT (ModuleFetcher (MMT m)) (ErrorT (StateT Modules (WriterT Infos m))) a }
deriving (Functor, Applicative, Monad, MonadReader (ModuleFetcher (MMT m)), MonadState Modules, MonadError ErrorMsg, MonadIO, MonadThrow, MonadCatch, MonadMask)
type MM = MMT IO
instance MonadMask m => MonadMask (ExceptT e m) where
mask f = ExceptT $ mask $ \u -> runExceptT $ f (mapExceptT u)
uninterruptibleMask = error "not implemented: uninterruptibleMask for ExcpetT"
mapMMT f (MMT m) = MMT $ f m
type Err a = (Either ErrorMsg a, Infos)
runMM :: Monad m => ModuleFetcher (MMT m) -> MMT m a -> m (Err a)
runMM fetcher
= runWriterT
. flip evalStateT mempty
. runExceptT
. flip runReaderT fetcher
. runMMT
catchErr :: (MonadCatch m, NFData a) => (String -> m a) -> m a -> m a
catchErr er m = (m >>= evaluate) `catch` getErr `catch` getPMatchFail
where
evaluate x = (return $!! x) >>= return
getErr (e :: ErrorCall) = catchErr er $ er $ show e
getPMatchFail (e :: PatternMatchFail) = catchErr er $ er $ show e
catchMM_ :: Monad m => MMT m a -> MMT m (Either ErrorMsg a)
catchMM_ = mapMMT $ mapReaderT $ \m -> lift $ runExceptT m
catchMM :: Monad m => MMT m a -> MMT m (Either String a)
catchMM = mapMMT $ mapReaderT $ \m -> lift $ either (Left . show) Right <$> runExceptT m
catchMM' :: Monad m => MMT m a -> (ErrorMsg -> MMT m a) -> MMT m a
catchMM' m e = catchMM_ m >>= either e return
-- TODO: remove dependent modules from cache too
removeFromCache :: Monad m => FilePath -> MMT m ()
removeFromCache f = modify $ Map.delete f
readFile' :: FilePath -> IO (Maybe String)
readFile' fname = do
b <- doesFileExist fname
if b then Just <$> readFile fname else return Nothing
ioFetch :: [FilePath] -> ModuleFetcher MM
ioFetch paths n = f fnames
where
f [] = throwErrorTCM $ "can't find module" <+> hsep (map text fnames)
f (x:xs) = liftIO (readFile' x) >>= \case
Nothing -> f xs
Just src -> return (x, src)
fnames = map lcModuleFile paths
lcModuleFile path = path </> (n ++ ".lc")
loadModule :: MonadMask m => MName -> MMT m PolyEnv
loadModule mname = do
fetch <- ask
(fname, src) <- fetch mname
c <- gets $ Map.lookup fname
case c of
Just (Right m) -> return m
Just (Left e) -> throwErrorTCM $ "cycles in module imports:" <+> pShow mname <+> e
_ -> do
e <- MMT $ lift $ mapExceptT (lift . lift) $ parseLC fname src
modify $ Map.insert fname $ Left $ pShow $ moduleImports e
do
ms <- mapM loadModule $ moduleImports e
x' <- trace ("loading " ++ fname) $ do
env <- joinPolyEnvs False ms
x <- MMT $ lift $ mapExceptT (lift . mapWriterT (return . runIdentity)) $ inference_ env e
case moduleExports e of
Nothing -> return x
Just es -> joinPolyEnvs False $ flip map es $ \exp -> case exp of
ExportModule m | m == mname -> x
ExportModule m -> case [ms | (m', ms) <- zip (moduleImports e) ms, m' == m] of
[x] -> x
modify $ Map.insert fname $ Right x'
return x'
-- `finally` modify (Map.delete fname)
`catchMM'` (\e -> modify (Map.delete fname) >> throwError e)
{- not used?
--getDef_ :: MName -> EName -> MM Exp
getDef_ m d = do
pe <- loadModule m
MMT $ return (getPolyEnv pe Map.! d)
getType = getType_ "Prelude"
getType_ m n = either (putStrLn . show) (putStrLn . ppShow . toExp . snd) . fst =<< runMM (ioFetch ["./tests/accept"]) (getDef_ (ExpN m) (ExpN n))
getDef'' m n = either (putStrLn . show) (either putStrLn (putStrLn . ppShow . fst)) . fst =<< runMM (ioFetch ["./tests/accept"]) (getDef (ExpN m) (ExpN n) Nothing)
-}
-- used in runTests
getDef :: MonadMask m => MName -> EName -> Maybe Exp -> MMT m (Either String Exp, Infos)
getDef m d ty = do
pe <- loadModule m
return
( case Map.lookup d $ getPolyEnv pe of
Just (th, thy)
| Just False <- (== toExp thy) <$> ty -> Left $ "type of " ++ d ++ " should be " ++ show ty ++ " instead of " ++ show (toExp thy) -- TODO: better type comparison
| otherwise -> Right $ toExp th
Nothing -> Left $ d ++ " is not found"
, infos pe
)
parseAndToCoreMain m = either (throwErrorTCM . text) return . (\(e, i) -> flip (,) i <$> e) =<< getDef m "main" (Just outputType)
compileMain_ :: MonadMask m => PolyEnv -> ModuleFetcher (MMT m) -> IR.Backend -> FilePath -> MName -> m (Err (IR.Pipeline, Infos))
compileMain_ prelude fetch backend path fname = runMM fetch $ do
modify $ Map.insert (path </> "Prelude.lc") $ Right prelude
(IR.compilePipeline True backend *** id) <$> parseAndToCoreMain fname
-- | most commonly used interface for end users
compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either String IR.Pipeline)
compileMain path backend fname = fmap ((show +++ fst) . fst) $ runMM (ioFetch path) $ (IR.compilePipeline True backend *** id) <$> parseAndToCoreMain fname
compileMain' :: MonadMask m => PolyEnv -> IR.Backend -> String -> m (Err (IR.Pipeline, Infos))
compileMain' prelude backend src = compileMain_ prelude fetch backend "." "Main"
where
fetch = \case
"Prelude" -> return ("./Prelude.lc", undefined)
"Main" -> return ("./Main.lc", src)
n -> throwErrorTCM $ "can't find module" <+> pShow n
-- used by the compiler-service of the online editor
preCompile :: MonadMask m => [FilePath] -> Backend -> String -> IO (String -> m (Err (IR.Pipeline, Infos)))
preCompile paths backend mod = do
res <- runMM (ioFetch paths) $ loadModule mod
case res of
(Right prelude, _) -> return $ compileMain' prelude backend
(Left err, i) -> error $ "Prelude could not compiled: " ++ show err
|
