diff options
-rw-r--r-- | TODO | 26 | ||||
-rw-r--r-- | src/LambdaCube/Compiler.hs | 232 | ||||
-rw-r--r-- | src/LambdaCube/Compiler/Infer.hs | 32 | ||||
-rw-r--r-- | src/LambdaCube/Compiler/Parser.hs | 16 | ||||
-rw-r--r-- | testdata/language-features/module/Hello02.out | 8 | ||||
-rw-r--r-- | testdata/language-features/module/Hello03.out | 8 | ||||
-rw-r--r-- | testdata/language-features/module/Moduledef08.out | 5 | ||||
-rw-r--r-- | testdata/language-features/module/Moduledef09.out | 8 | ||||
-rw-r--r-- | testdata/language-features/module/Moduledef10.out | 11 |
9 files changed, 198 insertions, 148 deletions
@@ -93,6 +93,29 @@ done: | |||
93 | - names have Int identifiers | 93 | - names have Int identifiers |
94 | 94 | ||
95 | next: | 95 | next: |
96 | - update API docs | ||
97 | - CHANGELOG | ||
98 | - better README | ||
99 | - editor: highlight errors in editor | ||
100 | - editor: editor socket reconnection | ||
101 | - register to stackage | ||
102 | |||
103 | |||
104 | |||
105 | * New Quake map viewer | ||
106 | - compiler: HOAS reducer | ||
107 | |||
108 | ===== compiler | ||
109 | * Frequencies & type classes, recursion | ||
110 | * Extra language features | ||
111 | * amiguity check & other checks | ||
112 | * Better error messages | ||
113 | * Speedup | ||
114 | |||
115 | |||
116 | |||
117 | |||
118 | |||
96 | - re-enable ambiguity checks | 119 | - re-enable ambiguity checks |
97 | - show desugared source code on a tab in the editor | 120 | - show desugared source code on a tab in the editor |
98 | - compiler optimization: HOAS iterpreter | 121 | - compiler optimization: HOAS iterpreter |
@@ -109,10 +132,7 @@ next: | |||
109 | fragment05uniform | 132 | fragment05uniform |
110 | - backend: basic pipeline optimization | 133 | - backend: basic pipeline optimization |
111 | 134 | ||
112 | - editor: highlight errors in editor | ||
113 | - editor: editor socket reconnection | ||
114 | 135 | ||
115 | - register to stackage | ||
116 | 136 | ||
117 | - docs: feature teaser, 2 min paper videos | 137 | - docs: feature teaser, 2 min paper videos |
118 | - minimal quake videos | 138 | - minimal quake videos |
diff --git a/src/LambdaCube/Compiler.hs b/src/LambdaCube/Compiler.hs index 54013b74..91c65666 100644 --- a/src/LambdaCube/Compiler.hs +++ b/src/LambdaCube/Compiler.hs | |||
@@ -15,7 +15,7 @@ module LambdaCube.Compiler | |||
15 | , MM, runMM | 15 | , MM, runMM |
16 | , Err | 16 | , Err |
17 | , catchMM, catchErr | 17 | , catchMM, catchErr |
18 | , ioFetch | 18 | , ioFetch, decideFilePath |
19 | , getDef, compileMain, preCompile | 19 | , getDef, compileMain, preCompile |
20 | , removeFromCache | 20 | , removeFromCache |
21 | 21 | ||
@@ -25,6 +25,7 @@ module LambdaCube.Compiler | |||
25 | ) where | 25 | ) where |
26 | 26 | ||
27 | import Data.List | 27 | import Data.List |
28 | import Data.Maybe | ||
28 | import Data.Function | 29 | import Data.Function |
29 | import Data.Map.Strict (Map) | 30 | import Data.Map.Strict (Map) |
30 | import qualified Data.Map.Strict as Map | 31 | import qualified Data.Map.Strict as Map |
@@ -46,34 +47,102 @@ import qualified Text.Show.Pretty as PP | |||
46 | import LambdaCube.IR as IR | 47 | import LambdaCube.IR as IR |
47 | import LambdaCube.Compiler.Pretty hiding ((</>)) | 48 | import LambdaCube.Compiler.Pretty hiding ((</>)) |
48 | import LambdaCube.Compiler.Parser (Module(..), Export(..), ImportItems (..), runDefParser, parseLC) | 49 | import LambdaCube.Compiler.Parser (Module(..), Export(..), ImportItems (..), runDefParser, parseLC) |
50 | import LambdaCube.Compiler.Lexer (DesugarInfo) | ||
49 | import LambdaCube.Compiler.Lexer as Exported (Range(..)) | 51 | import LambdaCube.Compiler.Lexer as Exported (Range(..)) |
50 | import LambdaCube.Compiler.Infer (PolyEnv(..), showError, joinPolyEnvs, filterPolyEnv, inference_) | 52 | import LambdaCube.Compiler.Infer (showError, inference, GlobalEnv, initEnv) |
51 | import LambdaCube.Compiler.Infer as Exported (Infos, listAllInfos, listTypeInfos, listTraceInfos, Exp, outputType, boolType, trueExp, unfixlabel) | 53 | import LambdaCube.Compiler.Infer as Exported (Infos, listAllInfos, listTypeInfos, listTraceInfos, Exp, outputType, boolType, trueExp, unfixlabel) |
52 | import LambdaCube.Compiler.CoreToIR | 54 | import LambdaCube.Compiler.CoreToIR |
53 | 55 | ||
54 | -- inlcude path for: Builtins, Internals and Prelude | 56 | -- inlcude path for: Builtins, Internals and Prelude |
55 | import Paths_lambdacube_compiler (getDataDir) | 57 | import Paths_lambdacube_compiler (getDataDir) |
56 | 58 | ||
57 | type EName = String | 59 | -------------------------------------------------------------------------------- |
58 | type MName = String | ||
59 | 60 | ||
60 | type Modules = Map FilePath (Either Doc (PolyEnv, String)) | 61 | readFileStrict :: FilePath -> IO String |
61 | type ModuleFetcher m = Maybe FilePath -> MName -> m (FilePath, MName, String) | 62 | readFileStrict = fmap T.unpack . TIO.readFile |
62 | 63 | ||
63 | -- todo: use RWS | 64 | readFile' :: FilePath -> IO (Maybe (IO String)) |
64 | newtype MMT m a = MMT { runMMT :: ExceptT String (ReaderT (ModuleFetcher (MMT m)) (StateT Modules (WriterT Infos m))) a } | 65 | readFile' fname = do |
65 | deriving (Functor, Applicative, Monad, MonadReader (ModuleFetcher (MMT m)), MonadState Modules, MonadError String, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadWriter Infos) | 66 | b <- doesFileExist fname |
66 | type MM = MMT IO | 67 | return $ if b then Just $ readFileStrict fname else Nothing |
67 | 68 | ||
68 | instance MonadMask m => MonadMask (ExceptT e m) where | 69 | instance MonadMask m => MonadMask (ExceptT e m) where |
69 | mask f = ExceptT $ mask $ \u -> runExceptT $ f (mapExceptT u) | 70 | mask f = ExceptT $ mask $ \u -> runExceptT $ f (mapExceptT u) |
70 | uninterruptibleMask = error "not implemented: uninterruptibleMask for ExcpetT" | 71 | uninterruptibleMask = error "not implemented: uninterruptibleMask for ExcpetT" |
71 | 72 | ||
73 | prettyShowUnlines :: Show a => a -> String | ||
74 | prettyShowUnlines = goPP 0 . PP.ppShow | ||
75 | where | ||
76 | goPP _ [] = [] | ||
77 | goPP n ('"':xs) | isMultilineString xs = "\"\"\"\n" ++ indent ++ go xs where | ||
78 | indent = replicate n ' ' | ||
79 | go ('\\':'n':xs) = "\n" ++ indent ++ go xs | ||
80 | go ('\\':c:xs) = '\\':c:go xs | ||
81 | go ('"':xs) = "\n" ++ indent ++ "\"\"\"" ++ goPP n xs | ||
82 | go (x:xs) = x : go xs | ||
83 | goPP n (x:xs) = x : goPP (if x == '\n' then 0 else n+1) xs | ||
84 | |||
85 | isMultilineString ('\\':'n':xs) = True | ||
86 | isMultilineString ('\\':c:xs) = isMultilineString xs | ||
87 | isMultilineString ('"':xs) = False | ||
88 | isMultilineString (x:xs) = isMultilineString xs | ||
89 | isMultilineString [] = False | ||
90 | |||
91 | -------------------------------------------------------------------------------- | ||
92 | |||
93 | type MName = String | ||
94 | type SName = String | ||
95 | type SourceCode = String | ||
96 | |||
97 | -- file name or module name? | ||
98 | decideFilePath n | ||
99 | | takeExtension n == ".lc" = Left n | ||
100 | | otherwise = Right n | ||
101 | |||
102 | dropExtension' e f | ||
103 | | takeExtension f == e = dropExtension f | ||
104 | | otherwise = error $ "dropExtension: expcted extension: " ++ e ++ " ; filename: " ++ f | ||
105 | |||
106 | fileNameToModuleName n | ||
107 | = intercalate "." $ remDot $ (\(a, b) -> map takeDirectory (splitPath a) ++ [b]) $ splitFileName $ dropExtension' ".lc" $ normalise n | ||
108 | where | ||
109 | remDot (".": xs) = xs | ||
110 | remDot xs = xs | ||
111 | |||
112 | moduleNameToFileName n = hn n ++ ".lc" | ||
113 | where | ||
114 | hn = h [] | ||
115 | h acc [] = reverse acc | ||
116 | h acc ('.':cs) = reverse acc </> hn cs | ||
117 | h acc (c: cs) = h (c: acc) cs | ||
118 | |||
119 | type ModuleFetcher m = Maybe FilePath -> Either FilePath MName -> m (FilePath, MName, m SourceCode) | ||
120 | |||
121 | ioFetch :: MonadIO m => [FilePath] -> ModuleFetcher (MMT m x) | ||
122 | ioFetch paths imp n = do | ||
123 | preludePath <- (</> "lc") <$> liftIO getDataDir | ||
124 | find $ nubBy ((==) `on` fst) $ map (first normalise . lcModuleFile) $ paths ++ [preludePath] | ||
125 | where | ||
126 | find ((x, mn): xs) = liftIO (readFile' x) >>= maybe (find xs) (\src -> return (x, mn, liftIO src)) | ||
127 | find [] = throwError $ show $ "can't find " <+> either (("lc file" <+>) . text) (("module" <+>) . text) n | ||
128 | <+> "in path" <+> hsep (map text paths) | ||
129 | |||
130 | lcModuleFile path = case n of | ||
131 | Left n -> (path </> n, fileNameToModuleName n) | ||
132 | Right n -> (path </> moduleNameToFileName n, n) | ||
133 | |||
134 | -------------------------------------------------------------------------------- | ||
135 | |||
136 | -- todo: use RWS | ||
137 | newtype MMT m x a = MMT { runMMT :: ExceptT String (ReaderT (ModuleFetcher (MMT m x)) (StateT (Modules x) (WriterT Infos m))) a } | ||
138 | deriving (Functor, Applicative, Monad, MonadReader (ModuleFetcher (MMT m x)), MonadState (Modules x), MonadError String, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadWriter Infos) | ||
139 | type MM = MMT IO Infos | ||
140 | |||
72 | mapMMT f (MMT m) = MMT $ f m | 141 | mapMMT f (MMT m) = MMT $ f m |
73 | 142 | ||
74 | type Err a = (Either String a, Infos) | 143 | type Err a = (Either String a, Infos) |
75 | 144 | ||
76 | runMM :: Monad m => ModuleFetcher (MMT m) -> MMT m a -> m (Err a) | 145 | runMM :: Monad m => ModuleFetcher (MMT m x) -> MMT m x a -> m (Err a) |
77 | runMM fetcher | 146 | runMM fetcher |
78 | = runWriterT | 147 | = runWriterT |
79 | . flip evalStateT mempty | 148 | . flip evalStateT mempty |
@@ -87,102 +156,74 @@ catchErr er m = (force <$> m >>= liftIO . evaluate) `catch` getErr `catch` getPM | |||
87 | getErr (e :: ErrorCall) = catchErr er $ er $ show e | 156 | getErr (e :: ErrorCall) = catchErr er $ er $ show e |
88 | getPMatchFail (e :: PatternMatchFail) = catchErr er $ er $ show e | 157 | getPMatchFail (e :: PatternMatchFail) = catchErr er $ er $ show e |
89 | 158 | ||
90 | catchMM :: Monad m => MMT m a -> (String -> Infos -> MMT m a) -> MMT m a | 159 | catchMM :: Monad m => MMT m x a -> (String -> Infos -> MMT m x a) -> MMT m x a |
91 | catchMM m e = mapMMT (lift . mapReaderT (mapStateT $ lift . runWriterT >=> f) . runExceptT) m >>= either (uncurry e) return | 160 | catchMM m e = mapMMT (lift . mapReaderT (mapStateT $ lift . runWriterT >=> f) . runExceptT) m >>= either (uncurry e) return |
92 | where | 161 | where |
93 | f ((Right x, m), is) = tell is >> return (Right x, m) | 162 | f ((Right x, m), is) = tell is >> return (Right x, m) |
94 | f ((Left e, m), is) = return (Left (e, is), m) | 163 | f ((Left e, m), is) = return (Left (e, is), m) |
95 | 164 | ||
96 | -- TODO: remove dependent modules from cache too? | 165 | -- TODO: remove dependent modules from cache too? |
97 | removeFromCache :: Monad m => FilePath -> MMT m () | 166 | removeFromCache :: Monad m => FilePath -> MMT m x () |
98 | removeFromCache f = modify $ Map.delete f | 167 | removeFromCache f = modify $ Map.delete f |
99 | 168 | ||
100 | readFileStrict :: FilePath -> IO String | 169 | type Module' x = (SourceCode, DesugarInfo, GlobalEnv, x) |
101 | readFileStrict = fmap T.unpack . TIO.readFile | ||
102 | 170 | ||
103 | readFile' :: FilePath -> IO (Maybe String) | 171 | type Modules x = Map FilePath (Either (SourceCode, Module) (Module' x)) |
104 | readFile' fname = do | ||
105 | b <- doesFileExist fname | ||
106 | if b then Just <$> readFileStrict fname else return Nothing | ||
107 | 172 | ||
108 | ioFetch :: MonadIO m => [FilePath] -> ModuleFetcher (MMT m) | 173 | loadModule :: MonadMask m => (Infos -> x) -> Maybe FilePath -> Either FilePath MName -> MMT m x (FilePath, Module' x) |
109 | ioFetch paths imp n = do | 174 | loadModule ex imp mname_ = do |
110 | preludePath <- (</> "lc") <$> liftIO getDataDir | 175 | (fname, mname, srcm) <- ask >>= \fetch -> fetch imp mname_ |
111 | let | ||
112 | fnames = nubBy ((==) `on` fst) $ map (first normalise) $ concatMap lcModuleFile $ paths ++ [preludePath] | ||
113 | lcModuleFile path = g imp | ||
114 | where | ||
115 | g _ | takeExtension n == ".lc" = [(path </> n, intercalate "." $ remDot $ (\(a, b) -> a ++ [b]) $ map takeDirectory . splitPath *** id $ splitFileName $ dropExtension $ normalise n)] | ||
116 | | otherwise = [(path </> hn n ++ ".lc", n)] | ||
117 | |||
118 | remDot (".": xs) = xs | ||
119 | remDot xs = xs | ||
120 | |||
121 | hn = h [] | ||
122 | h acc [] = reverse acc | ||
123 | h acc ('.':cs) = reverse acc </> hn cs | ||
124 | h acc (c: cs) = h (c: acc) cs | ||
125 | |||
126 | f [] = throwError $ show $ "can't find module" <+> text n <+> "in path" <+> hsep (map text paths) | ||
127 | f ((x, mn): xs) = liftIO (readFile' x) >>= \case | ||
128 | Nothing -> f xs | ||
129 | Just src -> do | ||
130 | --liftIO $ putStrLn $ "loading " ++ x | ||
131 | return (x, mn, src) | ||
132 | f fnames | ||
133 | |||
134 | loadModule :: MonadMask m => Maybe FilePath -> MName -> MMT m (FilePath, PolyEnv) | ||
135 | loadModule imp mname_ = do | ||
136 | fetch <- ask | ||
137 | (fname, mname, src) <- fetch imp mname_ | ||
138 | c <- gets $ Map.lookup fname | 176 | c <- gets $ Map.lookup fname |
139 | case c of | 177 | case c of |
140 | Just (Right (m, _)) -> return (fname, m) | 178 | Just (Right m) -> return (fname, m) |
141 | Just (Left e) -> throwError $ show $ "cycles in module imports:" <+> pShow mname <+> e | 179 | Just (Left (_, e)) -> throwError $ show $ "cycles in module imports:" <+> pShow mname <+> pShow (fst <$> moduleImports e) |
142 | _ -> do | 180 | _ -> do |
181 | src <- srcm | ||
143 | e <- either (throwError . show) return $ parseLC fname src | 182 | e <- either (throwError . show) return $ parseLC fname src |
144 | modify $ Map.insert fname $ Left $ pShow $ map fst $ moduleImports e | 183 | modify $ Map.insert fname $ Left (src, e) |
145 | let | 184 | let |
146 | loadModuleImports (m, is) = do | 185 | loadModuleImports (m, is) = do |
147 | filterPolyEnv (filterImports is) . snd <$> loadModule (Just fname) (snd m) | 186 | (_, (_, ds, ge, _)) <- loadModule ex (Just fname) (Right $ snd m) |
187 | return (ds{-todo: filter-}, Map.filterWithKey (\k _ -> filterImports is k) ge) | ||
188 | |||
189 | filterImports (ImportAllBut ns) = not . (`elem` map snd ns) | ||
190 | filterImports (ImportJust ns) = (`elem` map snd ns) | ||
148 | do | 191 | do |
149 | ms <- mapM loadModuleImports $ moduleImports e | 192 | ms <- mapM loadModuleImports $ moduleImports e |
150 | x' <- {-trace ("loading " ++ fname) $-} do | 193 | let (ds, ge) = mconcat ms |
151 | env@(PolyEnv ge _ ds) <- joinPolyEnvs False ms | 194 | (defs, dsinfo) <- MMT $ mapExceptT (return . runIdentity) $ runDefParser ds $ definitions e |
152 | defs <- MMT $ mapExceptT (return . runIdentity) $ runDefParser ds $ definitions e | 195 | srcs <- gets $ fmap $ either fst (\(src, _, _, _) -> src) |
153 | srcs <- gets $ Map.mapMaybe (either (const Nothing) (Just . snd)) | 196 | let |
154 | x <- MMT $ mapExceptT (lift . lift . mapWriterT (return . first (left $ showError (Map.insert fname src srcs)) . runIdentity)) $ inference_ env (extensions e) defs | 197 | -- todo: better story for info handling |
155 | case moduleExports e of | 198 | ff (Left e, is) = Left (showError srcs e) <$ tell is |
156 | Nothing -> return x | 199 | ff (Right ge, is) = return $ Right (mconcat ge, is) |
157 | Just es -> joinPolyEnvs False $ flip map es $ \exp -> case exp of | 200 | (newge, is) <- MMT $ mapExceptT (lift . lift . mapWriterT (return . runIdentity) . (ff <=< runWriterT . flip runReaderT (extensions e, initEnv <> ge))) $ inference defs |
158 | ExportId (snd -> d) -> case Map.lookup d $ getPolyEnv x of | 201 | (ds', ge') <- fmap mconcat $ forM (fromMaybe [ExportModule (mempty, mname)] $ moduleExports e) $ \exp -> case exp of |
159 | Just def -> PolyEnv (Map.singleton d def) mempty mempty{-TODO-} | 202 | ExportId (snd -> d) -> case Map.lookup d newge of |
160 | Nothing -> error $ d ++ " is not defined" | 203 | Just def -> return (mempty{-TODO-}, Map.singleton d def) |
161 | ExportModule (snd -> m) | m == mname -> x | 204 | Nothing -> error $ d ++ " is not defined" |
162 | ExportModule m -> case [ ms | 205 | ExportModule (snd -> m) | m == mname -> return (dsinfo, newge) |
163 | | ((m', is), ms) <- zip (moduleImports e) ms, m' == m] of | 206 | ExportModule m -> case [ x | ((m', _), x) <- zip (moduleImports e) ms, m' == m] of |
164 | [PolyEnv x infos ds] -> PolyEnv x mempty{-TODO-} ds | 207 | [x] -> return x |
165 | [] -> error $ "empty export list: " ++ show (fname, m, map fst $ moduleImports e, mname) | 208 | [] -> throwError $ "empty export list: " ++ show (fname, m, map fst $ moduleImports e, mname) |
166 | _ -> error "export list: internal error" | 209 | _ -> error "export list: internal error" |
167 | modify $ Map.insert fname $ Right (x', src) | 210 | let m = (src, ds', ge', ex is) |
168 | return (fname, x') | 211 | modify $ Map.insert fname $ Right m |
212 | return (fname, m) | ||
169 | `catchMM` (\e is -> modify (Map.delete fname) >> tell is >> throwError e) | 213 | `catchMM` (\e is -> modify (Map.delete fname) >> tell is >> throwError e) |
170 | 214 | ||
171 | filterImports (ImportAllBut ns) = not . (`elem` map snd ns) | ||
172 | filterImports (ImportJust ns) = (`elem` map snd ns) | ||
173 | |||
174 | -- used in runTests | 215 | -- used in runTests |
175 | getDef :: MonadMask m => MName -> EName -> Maybe Exp -> MMT m (FilePath, Either String (Exp, Exp), Infos) | 216 | getDef :: MonadMask m => FilePath -> SName -> Maybe Exp -> MMT m Infos (FilePath, Either String (Exp, Exp), Infos) |
176 | getDef m d ty = do | 217 | getDef m d ty = do |
177 | (fname, pe) <- loadModule Nothing m | 218 | (fname, (_, _, ge, infos)) <- loadModule id Nothing $ Left m |
178 | return | 219 | return |
179 | ( fname | 220 | ( fname |
180 | , case Map.lookup d $ getPolyEnv pe of | 221 | , case Map.lookup d ge of |
181 | Just (e, thy, si) | 222 | Just (e, thy, si) |
182 | | Just False <- (== thy) <$> ty -> Left $ "type of " ++ d ++ " should be " ++ show ty ++ " instead of " ++ ppShow thy -- TODO: better type comparison | 223 | | Just False <- (== thy) <$> ty -> Left $ "type of " ++ d ++ " should be " ++ show ty ++ " instead of " ++ ppShow thy -- TODO: better type comparison |
183 | | otherwise -> Right (e, thy) | 224 | | otherwise -> Right (e, thy) |
184 | Nothing -> Left $ d ++ " is not found" | 225 | Nothing -> Left $ d ++ " is not found" |
185 | , infos pe | 226 | , infos |
186 | ) | 227 | ) |
187 | 228 | ||
188 | parseAndToCoreMain m = either throwError return . (\(_, e, i) -> flip (,) i <$> e) =<< getDef m "main" (Just outputType) | 229 | parseAndToCoreMain m = either throwError return . (\(_, e, i) -> flip (,) i <$> e) =<< getDef m "main" (Just outputType) |
@@ -190,41 +231,22 @@ parseAndToCoreMain m = either throwError return . (\(_, e, i) -> flip (,) i <$> | |||
190 | -- | most commonly used interface for end users | 231 | -- | most commonly used interface for end users |
191 | compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either String IR.Pipeline) | 232 | compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either String IR.Pipeline) |
192 | compileMain path backend fname | 233 | compileMain path backend fname |
193 | = fmap ((id +++ fst) . fst) $ runMM (ioFetch path) $ first (compilePipeline backend) <$> parseAndToCoreMain fname | 234 | = fmap (right fst . fst) $ runMM (ioFetch path) $ first (compilePipeline backend) <$> parseAndToCoreMain fname |
194 | |||
195 | -- | Removes the escaping characters from the error message | ||
196 | removeEscapes = first (removeEscs +++ id) | ||
197 | 235 | ||
198 | -- used by the compiler-service of the online editor | 236 | -- used by the compiler-service of the online editor |
199 | preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> String -> IO (String -> m (Err (IR.Pipeline, Infos))) | 237 | preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> FilePath -> IO (String -> m (Err (IR.Pipeline, Infos))) |
200 | preCompile paths paths' backend mod = do | 238 | preCompile paths paths' backend mod = do |
201 | res <- runMM (ioFetch paths) $ loadModule Nothing mod | 239 | res <- runMM (ioFetch paths) $ loadModule id Nothing $ Left mod |
202 | case res of | 240 | case res of |
203 | (Left err, i) -> error $ "Prelude could not compiled: " ++ err | 241 | (Left err, i) -> error $ "Prelude could not compiled: " ++ err |
204 | (Right (_, prelude), _) -> return compile | 242 | (Right (_, prelude), _) -> return compile |
205 | where | 243 | where |
206 | compile src = fmap removeEscapes . runMM fetch $ do | 244 | compile src = fmap (first (left removeEscs)) . runMM fetch $ do |
207 | modify $ Map.insert ("." </> "Prelude.lc") $ Right (prelude, "<<TODO>>") | 245 | modify $ Map.insert ("." </> "Prelude.lc") $ Right prelude |
208 | first (compilePipeline backend) <$> parseAndToCoreMain "Main" | 246 | first (compilePipeline backend) <$> parseAndToCoreMain "Main" |
209 | where | 247 | where |
210 | fetch imp = \case | 248 | fetch imp = \case |
211 | "Prelude" -> return ("./Prelude.lc", "Prelude", undefined) | 249 | Right "Prelude" -> return ("./Prelude.lc", "Prelude", undefined) |
212 | "Main" -> return ("./Main.lc", "Main", src) | 250 | Right "Main" -> return ("./Main.lc", "Main", return src) |
213 | n -> ioFetch paths' imp n | 251 | n -> ioFetch paths' imp n |
214 | 252 | ||
215 | prettyShowUnlines :: Show a => a -> String | ||
216 | prettyShowUnlines = goPP 0 . PP.ppShow | ||
217 | where goPP _ [] = [] | ||
218 | goPP n ('"':xs) | isMultilineString xs = "\"\"\"\n" ++ indent ++ go xs where | ||
219 | indent = replicate n ' ' | ||
220 | go ('\\':'n':xs) = "\n" ++ indent ++ go xs | ||
221 | go ('\\':c:xs) = '\\':c:go xs | ||
222 | go ('"':xs) = "\n" ++ indent ++ "\"\"\"" ++ goPP n xs | ||
223 | go (x:xs) = x : go xs | ||
224 | goPP n (x:xs) = x : goPP (if x == '\n' then 0 else n+1) xs | ||
225 | |||
226 | isMultilineString ('\\':'n':xs) = True | ||
227 | isMultilineString ('\\':c:xs) = isMultilineString xs | ||
228 | isMultilineString ('"':xs) = False | ||
229 | isMultilineString (x:xs) = isMultilineString xs | ||
230 | isMultilineString [] = False | ||
diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs index c43fc8ff..16381ba4 100644 --- a/src/LambdaCube/Compiler/Infer.hs +++ b/src/LambdaCube/Compiler/Infer.hs | |||
@@ -24,7 +24,7 @@ module LambdaCube.Compiler.Infer | |||
24 | , initEnv, Env(..), pattern EBind2 | 24 | , initEnv, Env(..), pattern EBind2 |
25 | , SI(..), Range(..) -- todo: remove | 25 | , SI(..), Range(..) -- todo: remove |
26 | , Info(..), Infos, listAllInfos, listTypeInfos, listTraceInfos | 26 | , Info(..), Infos, listAllInfos, listTypeInfos, listTraceInfos |
27 | , PolyEnv(..), joinPolyEnvs, filterPolyEnv, inference_ | 27 | , inference, IM |
28 | , nType, conType, neutType, neutType', appTy, mkConPars, makeCaseFunPars, makeCaseFunPars' | 28 | , nType, conType, neutType, neutType', appTy, mkConPars, makeCaseFunPars, makeCaseFunPars' |
29 | , MaxDB, unfixlabel | 29 | , MaxDB, unfixlabel |
30 | , ErrorMsg, showError | 30 | , ErrorMsg, showError |
@@ -42,7 +42,6 @@ import Control.Monad.Except | |||
42 | import Control.Monad.Reader | 42 | import Control.Monad.Reader |
43 | import Control.Monad.Writer | 43 | import Control.Monad.Writer |
44 | import Control.Monad.State | 44 | import Control.Monad.State |
45 | import Control.Monad.Identity | ||
46 | import Control.Arrow hiding ((<+>)) | 45 | import Control.Arrow hiding ((<+>)) |
47 | import Control.DeepSeq | 46 | import Control.DeepSeq |
48 | 47 | ||
@@ -1366,27 +1365,12 @@ downTo n m = map Var [n+m-1, n+m-2..n] | |||
1366 | 1365 | ||
1367 | defined' = Map.keys | 1366 | defined' = Map.keys |
1368 | 1367 | ||
1368 | -- todo: proper handling of implicit foralls | ||
1369 | addF = asks $ \(exs, ge) -> addForalls exs $ defined' ge | 1369 | addF = asks $ \(exs, ge) -> addForalls exs $ defined' ge |
1370 | 1370 | ||
1371 | tellType si t = tell $ mkInfoItem (sourceInfo si) $ removeEscs $ showDoc $ mkDoc True (t, TType) | 1371 | tellType si t = tell $ mkInfoItem (sourceInfo si) $ removeEscs $ showDoc $ mkDoc True (t, TType) |
1372 | 1372 | ||
1373 | 1373 | ||
1374 | -------------------------------------------------------------------------------- inference output | ||
1375 | |||
1376 | data PolyEnv = PolyEnv | ||
1377 | { getPolyEnv :: GlobalEnv | ||
1378 | , infos :: Infos | ||
1379 | , dsInfo :: DesugarInfo | ||
1380 | } | ||
1381 | |||
1382 | filterPolyEnv p pe = pe { getPolyEnv = Map.filterWithKey (\k _ -> p k) $ getPolyEnv pe } | ||
1383 | |||
1384 | joinPolyEnvs :: MonadError String m => Bool -> [PolyEnv] -> m PolyEnv | ||
1385 | joinPolyEnvs _ = return . foldr mappend' mempty' -- todo | ||
1386 | where | ||
1387 | mempty' = PolyEnv mempty mempty mempty | ||
1388 | PolyEnv a b c `mappend'` PolyEnv a' b' c' = PolyEnv (a `mappend` a') (b `mappend` b') (c `joinDesugarInfo` c') | ||
1389 | |||
1390 | -------------------------------------------------------------------------------- pretty print | 1374 | -------------------------------------------------------------------------------- pretty print |
1391 | -- todo: do this via conversion to SExp | 1375 | -- todo: do this via conversion to SExp |
1392 | 1376 | ||
@@ -1522,20 +1506,10 @@ getList (unfixlabel -> ConN FCons [x, xs]) = (x:) <$> getList xs | |||
1522 | getList (unfixlabel -> ConN FNil []) = Just [] | 1506 | getList (unfixlabel -> ConN FNil []) = Just [] |
1523 | getList _ = Nothing | 1507 | getList _ = Nothing |
1524 | 1508 | ||
1525 | 1509 | -------------------------------------------------------------------------------- tools | |
1526 | -------------------------------------------------------------------------------- main | ||
1527 | 1510 | ||
1528 | mfix' f = ExceptT (mfix (runExceptT . f . either bomb id)) | 1511 | mfix' f = ExceptT (mfix (runExceptT . f . either bomb id)) |
1529 | where bomb e = error $ "mfix (ExceptT): inner computation returned Left value:\n" ++ show e | 1512 | where bomb e = error $ "mfix (ExceptT): inner computation returned Left value:\n" ++ show e |
1530 | 1513 | ||
1531 | inference_ :: MonadFix m => PolyEnv -> Extensions -> [Stmt] -> ExceptT ErrorMsg (WriterT Infos m) PolyEnv | ||
1532 | inference_ (PolyEnv pe is _) exts defs = mapExceptT (ff <=< runWriterT . flip runReaderT (exts, initEnv <> pe)) $ inference defs | ||
1533 | where | ||
1534 | ff (Left e, is) = do | ||
1535 | tell is | ||
1536 | return $ Left e | ||
1537 | ff (Right ge, is) = do | ||
1538 | return $ Right $ PolyEnv (mconcat ge) is $ mkDesugarInfo defs | ||
1539 | |||
1540 | foldlrev f = foldr (flip f) | 1514 | foldlrev f = foldr (flip f) |
1541 | 1515 | ||
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs index e64327de..389d2364 100644 --- a/src/LambdaCube/Compiler/Parser.hs +++ b/src/LambdaCube/Compiler/Parser.hs | |||
@@ -18,7 +18,6 @@ module LambdaCube.Compiler.Parser | |||
18 | , debug, isPi, varDB, lowerDB, upDB, notClosed, cmpDB, MaxDB(..), iterateN, traceD | 18 | , debug, isPi, varDB, lowerDB, upDB, notClosed, cmpDB, MaxDB(..), iterateN, traceD |
19 | , parseLC, runDefParser | 19 | , parseLC, runDefParser |
20 | , getParamsS, addParamsS, getApps, apps', downToS, addForalls | 20 | , getParamsS, addParamsS, getApps, apps', downToS, addForalls |
21 | , mkDesugarInfo, joinDesugarInfo | ||
22 | , Up (..), up1, up | 21 | , Up (..), up1, up |
23 | , Doc, shLam, shApp, shLet, shLet_, shAtom, shAnn, shVar, epar, showDoc, showDoc_, sExpDoc, shCstr, shTuple | 22 | , Doc, shLam, shApp, shLet, shLet_, shAtom, shAnn, shVar, epar, showDoc, showDoc_, sExpDoc, shCstr, shTuple |
24 | , mtrace, sortDefs | 23 | , mtrace, sortDefs |
@@ -1008,9 +1007,6 @@ mkDesugarInfo ss = | |||
1008 | hackHList ("HNil", _) = ("HNil", Left (("hlistNilCase", -1), [("HNil", 0)])) | 1007 | hackHList ("HNil", _) = ("HNil", Left (("hlistNilCase", -1), [("HNil", 0)])) |
1009 | hackHList x = x | 1008 | hackHList x = x |
1010 | 1009 | ||
1011 | joinDesugarInfo (fm, cm) (fm', cm') = (Map.union fm fm', Map.union cm cm') | ||
1012 | |||
1013 | |||
1014 | -------------------------------------------------------------------------------- module exports | 1010 | -------------------------------------------------------------------------------- module exports |
1015 | 1011 | ||
1016 | data Export = ExportModule SIName | ExportId SIName | 1012 | data Export = ExportModule SIName | ExportId SIName |
@@ -1102,19 +1098,17 @@ parseLC f str | |||
1102 | $ str | 1098 | $ str |
1103 | 1099 | ||
1104 | --type DefParser = DesugarInfo -> (Either ParseError [Stmt], [PostponedCheck]) | 1100 | --type DefParser = DesugarInfo -> (Either ParseError [Stmt], [PostponedCheck]) |
1105 | runDefParser :: (MonadFix m, MonadError String m) => DesugarInfo -> DefParser -> m [Stmt] | 1101 | runDefParser :: (MonadFix m, MonadError String m) => DesugarInfo -> DefParser -> m ([Stmt], DesugarInfo) |
1106 | runDefParser ds_ dp = do | 1102 | runDefParser ds_ dp = do |
1107 | 1103 | ||
1108 | ((defs, dns), ds) <- mfix $ \ ~(_, ds) -> do | 1104 | (defs, dns, ds) <- mfix $ \ ~(_, _, ds) -> do |
1109 | let (x, dns) = dp ds | 1105 | let (x, dns) = dp (ds <> ds_) |
1110 | defs <- either (throwError . show) return x | 1106 | defs <- either (throwError . show) return x |
1111 | let ds' = mkDesugarInfo defs `joinDesugarInfo` ds_ | 1107 | return (defs, dns, mkDesugarInfo defs) |
1112 | return ((defs, dns), ds') | ||
1113 | 1108 | ||
1114 | mapM_ (maybe (return ()) throwError) dns | 1109 | mapM_ (maybe (return ()) throwError) dns |
1115 | 1110 | ||
1116 | return $ sortDefs ds defs | 1111 | return (sortDefs ds defs, ds) |
1117 | |||
1118 | 1112 | ||
1119 | -------------------------------------------------------------------------------- pretty print | 1113 | -------------------------------------------------------------------------------- pretty print |
1120 | 1114 | ||
diff --git a/testdata/language-features/module/Hello02.out b/testdata/language-features/module/Hello02.out index 8fcbc3af..71039060 100644 --- a/testdata/language-features/module/Hello02.out +++ b/testdata/language-features/module/Hello02.out | |||
@@ -1 +1,9 @@ | |||
1 | main is not found | 1 | main is not found |
2 | ------------ trace | ||
3 | hello :: [32m'String[39m[K | ||
4 | world :: [32m'String[39m[K | ||
5 | ------------ tooltips | ||
6 | testdata/language-features/module/Hello02.lc 3:1-3:6 String | ||
7 | testdata/language-features/module/Hello02.lc 3:9-3:16 String | ||
8 | testdata/language-features/module/Hello02.lc 4:1-4:6 String | ||
9 | testdata/language-features/module/Hello02.lc 4:9-4:16 String | ||
diff --git a/testdata/language-features/module/Hello03.out b/testdata/language-features/module/Hello03.out index 8fcbc3af..899f1f33 100644 --- a/testdata/language-features/module/Hello03.out +++ b/testdata/language-features/module/Hello03.out | |||
@@ -1 +1,9 @@ | |||
1 | main is not found | 1 | main is not found |
2 | ------------ trace | ||
3 | greeting :: [32m'Char[39m[K | ||
4 | value :: [32m'Float[39m[K | ||
5 | ------------ tooltips | ||
6 | testdata/language-features/module/Hello03.lc 7:1-7:9 Char | ||
7 | testdata/language-features/module/Hello03.lc 7:12-7:15 Char | ||
8 | testdata/language-features/module/Hello03.lc 9:1-9:6 Float | ||
9 | testdata/language-features/module/Hello03.lc 9:9-9:13 Float | ||
diff --git a/testdata/language-features/module/Moduledef08.out b/testdata/language-features/module/Moduledef08.out index 8fcbc3af..b361bfeb 100644 --- a/testdata/language-features/module/Moduledef08.out +++ b/testdata/language-features/module/Moduledef08.out | |||
@@ -1 +1,6 @@ | |||
1 | main is not found | 1 | main is not found |
2 | ------------ trace | ||
3 | hello :: [32m'String[39m[K | ||
4 | ------------ tooltips | ||
5 | testdata/language-features/module/Moduledef08.lc 5:1-5:6 String | ||
6 | testdata/language-features/module/Moduledef08.lc 5:9-5:16 String | ||
diff --git a/testdata/language-features/module/Moduledef09.out b/testdata/language-features/module/Moduledef09.out index 8fcbc3af..59f23c4d 100644 --- a/testdata/language-features/module/Moduledef09.out +++ b/testdata/language-features/module/Moduledef09.out | |||
@@ -1 +1,9 @@ | |||
1 | main is not found | 1 | main is not found |
2 | ------------ trace | ||
3 | hello :: [32m'String[39m[K | ||
4 | world :: [32m'String[39m[K | ||
5 | ------------ tooltips | ||
6 | testdata/language-features/module/Moduledef09.lc 5:1-5:6 String | ||
7 | testdata/language-features/module/Moduledef09.lc 5:9-5:16 String | ||
8 | testdata/language-features/module/Moduledef09.lc 6:1-6:6 String | ||
9 | testdata/language-features/module/Moduledef09.lc 6:9-6:16 String | ||
diff --git a/testdata/language-features/module/Moduledef10.out b/testdata/language-features/module/Moduledef10.out index 8fcbc3af..466f5547 100644 --- a/testdata/language-features/module/Moduledef10.out +++ b/testdata/language-features/module/Moduledef10.out | |||
@@ -1 +1,12 @@ | |||
1 | main is not found | 1 | main is not found |
2 | ------------ trace | ||
3 | hello :: [32m'String[39m[K | ||
4 | world :: [32m'String[39m[K | ||
5 | value :: [32m()[39m[K | ||
6 | ------------ tooltips | ||
7 | testdata/language-features/module/Moduledef10.lc 6:1-6:6 String | ||
8 | testdata/language-features/module/Moduledef10.lc 6:9-6:16 String | ||
9 | testdata/language-features/module/Moduledef10.lc 7:1-7:6 String | ||
10 | testdata/language-features/module/Moduledef10.lc 7:9-7:16 String | ||
11 | testdata/language-features/module/Moduledef10.lc 9:1-9:6 () | ||
12 | testdata/language-features/module/Moduledef10.lc 9:9-9:11 () | ||