Skip to content

Commit 23e8832

Browse files
dougalmdougalm
committed
Controlled burn
1 parent d8fe2d4 commit 23e8832

30 files changed

+1924
-996
lines changed

‎dex.cabal

Lines changed: 20 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -41,19 +41,19 @@ flag debug
4141

4242
library
4343
exposed-modules: AbstractSyntax
44-
, Builder
45-
, CUDA
46-
, CheapReduction
44+
-- , Builder
45+
-- , CUDA
46+
-- , CheapReduction
4747
-- , CheckType
4848
, ConcreteSyntax
49-
, Core
50-
, DPS
49+
-- , Core
50+
-- , DPS
5151
, Err
52-
, Generalize
53-
, Imp
54-
, ImpToLLVM
52+
-- , Generalize
53+
-- , Imp
54+
-- , ImpToLLVM
5555
, IncState
56-
, Inference
56+
-- , Inference
5757
-- , Inline
5858
-- , JAX.Concrete
5959
-- , JAX.Rename
@@ -73,29 +73,29 @@ library
7373
-- , PeepholeOptimize
7474
, PPrint
7575
, RawName
76-
, Runtime
76+
-- , Runtime
7777
-- , RuntimePrint
78-
, Serialize
79-
, Simplify
80-
, Subst
78+
-- , Serialize
79+
-- , Simplify
80+
-- , Subst
8181
, SourceRename
8282
, SourceIdTraversal
83-
, TopLevel
83+
, TopLevel2
8484
-- , Transpose
8585
, Types.Simple
8686
, Types.Complicated
8787
, Types.Imp
8888
, Types.Primitives
8989
, Types.Source
90-
, Types.Top
91-
, QueryType
92-
, QueryTypePure
90+
, Types.Top2
91+
-- , QueryType
92+
-- , QueryTypePure
9393
, Util
9494
-- , Vectorize
9595
, Actor
96-
, Live.Eval
97-
, Live.Web
98-
, RenderHtml
96+
-- , Live.Eval
97+
-- , Live.Web
98+
-- , RenderHtml
9999
other-modules: Paths_dex
100100
build-depends: base
101101
, bytestring

‎src/dex.hs

Lines changed: 29 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -19,15 +19,12 @@ import qualified Data.Map.Strict as M
1919
import qualified System.Console.ANSI as ANSI
2020
import System.Console.ANSI hiding (Color)
2121

22-
import TopLevel
22+
import Types.Source
23+
import TopLevel2
2324
import AbstractSyntax (parseTopDeclRepl)
2425
import ConcreteSyntax (keyWordStrs, preludeImportBlock)
25-
import Live.Web
26+
-- import Live.Web
2627
import PPrint hiding (hardline)
27-
import Core
28-
import Types.Imp
29-
import Types.Source
30-
import Types.Top
3128
import MonadUtil
3229
import Util (readFileText)
3330

@@ -45,43 +42,44 @@ data CmdOpts = CmdOpts EvalMode EvalConfig
4542
runMode :: CmdOpts -> IO ()
4643
runMode (CmdOpts evalMode cfg) = case evalMode of
4744
ScriptMode fname fmt -> do
48-
env <- loadCache
45+
env <- initTopState -- loadCache
4946
((), finalEnv) <- runTopperM cfg stdOutLogger env do
5047
blocks <- parseSourceBlocks <$> readFileText fname
5148
forM_ blocks \block -> do
5249
case fmt of
5350
ResultOnly -> return ()
5451
TextDoc -> liftIO $ putStr $ pprint block
5552
evalSourceBlockRepl block
56-
storeCache finalEnv
57-
ReplMode -> do
58-
env <- loadCache
59-
void $ runTopperM cfg stdOutLogger env do
60-
void $ evalSourceBlockRepl preludeImportBlock
61-
forever do
62-
block <- readSourceBlock
63-
void $ evalSourceBlockRepl block
64-
WebMode fname -> do
65-
env <- loadCache
66-
runWeb fname cfg env
67-
GenerateHTML fname dest -> do
68-
env <- loadCache
69-
generateHTML fname dest cfg env
70-
ClearCache -> clearCache
53+
return ()
54+
-- storeCache finalEnv
55+
-- ReplMode -> do
56+
-- env <- loadCache
57+
-- void $ runTopperM cfg stdOutLogger env do
58+
-- void $ evalSourceBlockRepl preludeImportBlock
59+
-- forever do
60+
-- block <- readSourceBlock
61+
-- void $ evalSourceBlockRepl block
62+
-- WebMode fname -> do
63+
-- env <- loadCache
64+
-- runWeb fname cfg env
65+
-- GenerateHTML fname dest -> do
66+
-- env <- loadCache
67+
-- generateHTML fname dest cfg env
68+
-- ClearCache -> clearCache
7169

7270
stdOutLogger :: Outputs -> IO ()
7371
stdOutLogger (Outputs outs) = do
7472
isatty <- queryTerminal stdOutput
7573
forM_ outs \out -> putStr $ printOutput isatty out
7674

77-
readSourceBlock :: (MonadIO (m n), EnvReader m) => m n SourceBlock
78-
readSourceBlock = do
79-
sourceMap <- withEnv $ envSourceMap . moduleEnv
80-
let filenameAndDexCompletions =
81-
completeQuotedWord (Just '\\') "\"'" listFiles (dexCompletions sourceMap)
82-
let hasklineSettings = setComplete filenameAndDexCompletions defaultSettings
83-
liftIO $ runInputT hasklineSettings $ readMultiline prompt (parseTopDeclRepl . T.pack)
84-
where prompt = ">=> "
75+
-- readSourceBlock :: MonadIO (m n) => m n SourceBlock
76+
-- readSourceBlock = do
77+
-- sourceMap <- withEnv $ envSourceMap . moduleEnv
78+
-- let filenameAndDexCompletions =
79+
-- completeQuotedWord (Just '\\') "\"'" listFiles (dexCompletions sourceMap)
80+
-- let hasklineSettings = setComplete filenameAndDexCompletions defaultSettings
81+
-- liftIO $ runInputT hasklineSettings $ readMultiline prompt (parseTopDeclRepl . T.pack)
82+
-- where prompt = ">=> "
8583

8684
dexCompletions :: Monad m => SourceMap n -> CompletionFunc m
8785
dexCompletions sourceMap (line, _) = do
@@ -145,8 +143,7 @@ enumOption optName prettyOptName defaultVal options = option
145143

146144
parseEvalOpts :: Parser EvalConfig
147145
parseEvalOpts = EvalConfig
148-
<$> enumOption "backend" "Backend" LLVM backends
149-
<*> (option pathOption $ long "lib-path" <> value [LibBuiltinPath]
146+
<$> (option pathOption $ long "lib-path" <> value [LibBuiltinPath]
150147
<> metavar "PATH" <> help "Library path")
151148
<*> optional (strOption $ long "prelude" <> metavar "FILE" <> help "Prelude file")
152149
<*> flag NoOptimize Optimize (short 'O' <> help "Optimize generated code")
@@ -155,8 +152,6 @@ parseEvalOpts = EvalConfig
155152
where
156153
printBackends = [ ("haskell", PrintHaskell)
157154
, ("dex" , PrintCodegen) ]
158-
backends = [ ("llvm" , LLVM )
159-
, ("llvm-mc", LLVMMC) ]
160155
logLevels = [ ("normal", NormalLogLevel)
161156
, ("debug" , DebugLogLevel ) ]
162157

‎src/lib/AbstractSyntax.hs

Lines changed: 48 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,7 @@ import Util
6969
parseExpr :: Fallible m => GroupW -> m (UExpr VoidS)
7070
parseExpr e = liftSyntaxM $ expr e
7171

72-
parseDecl :: Fallible m => CTopDeclW -> m (UTopDecl VoidS VoidS)
72+
parseDecl :: Fallible m => CTopDeclW -> m UTopDecl
7373
parseDecl d = liftSyntaxM $ topDecl d
7474

7575
parseBlock :: Fallible m => CSBlock -> m (UBlock VoidS)
@@ -93,46 +93,44 @@ checkSourceBlockParses = \case
9393
when (ann /= PlainLet) $ fail "Cannot annotate expressions"
9494
void $ expr e
9595
TopDecl d -> void $ topDecl d
96-
Command _ b -> void $ expr b
97-
DeclareForeign _ _ ty -> void $ expr ty
98-
DeclareCustomLinearization _ _ body -> void $ expr body
9996
Misc _ -> return ()
10097
UnParseable _ _ -> return ()
10198

10299
-- === Converting concrete syntax to abstract syntax ===
103100

104101
type SyntaxM = Except
105102

106-
topDecl :: CTopDeclW -> SyntaxM (UTopDecl VoidS VoidS)
107-
topDecl (WithSrcs sid sids topDecl') = case topDecl' of
108-
CSDecl ann d -> ULocalDecl <$> decl ann (WithSrcs sid sids d)
109-
CData name tyConParams givens constructors -> do
110-
tyConParams' <- fromMaybeM tyConParams Empty aExplicitParams
111-
givens' <- aOptGivens givens
112-
constructors' <- forM constructors \(v, ps) -> do
113-
ps' <- fromMaybeM ps Empty \(WithSrcs _ _ ps') ->
114-
toNest <$> mapM (tyOptBinder Explicit) ps'
115-
return (v, ps')
116-
return $ UDataDefDecl
117-
(UDataDef (withoutSrc name) (givens' >>> tyConParams') $
118-
map (\(name', cons) -> (withoutSrc name', UDataDefTrail cons)) constructors')
119-
(fromSourceNameW name)
120-
(toNest $ map (fromSourceNameW . fst) constructors')
121-
CStruct name params givens fields defs -> do
122-
params' <- fromMaybeM params Empty aExplicitParams
123-
givens' <- aOptGivens givens
124-
fields' <- forM fields \(v, ty) -> (v,) <$> expr ty
125-
methods <- forM defs \(ann, d) -> do
126-
(WithSrc _ methodName, lam) <- aDef d
127-
return (ann, methodName, Abs (WithSrcB sid (UBindSource "self")) lam)
128-
return $ UStructDecl (fromSourceNameW name) (UStructDef (withoutSrc name) (givens' >>> params') fields' methods)
129-
CInterface name params methods -> do
130-
params' <- aExplicitParams params
131-
(methodNames, methodTys) <- unzip <$> forM methods \(methodName, ty) -> do
132-
ty' <- expr ty
133-
return (fromSourceNameW methodName, ty')
134-
return $ UInterface params' methodTys (fromSourceNameW name) (toNest methodNames)
135-
CInstanceDecl def -> aInstanceDef def
103+
topDecl :: CTopDeclW -> SyntaxM UTopDecl
104+
topDecl (WithSrcs sid sids topDecl') = undefined
105+
-- topDecl (WithSrcs sid sids topDecl') = case topDecl' of
106+
-- CSDecl ann d -> UTopLet <$> decl ann (WithSrcs sid sids d)
107+
-- CData name tyConParams givens constructors -> do
108+
-- tyConParams' <- fromMaybeM tyConParams Empty aExplicitParams
109+
-- givens' <- aOptGivens givens
110+
-- constructors' <- forM constructors \(v, ps) -> do
111+
-- ps' <- fromMaybeM ps Empty \(WithSrcs _ _ ps') ->
112+
-- toNest <$> mapM (tyOptBinder Explicit) ps'
113+
-- return (v, ps')
114+
-- return $ UDataDefDecl
115+
-- (UDataDef (withoutSrc name) (givens' >>> tyConParams') $
116+
-- map (\(name', cons) -> (withoutSrc name', UDataDefTrail cons)) constructors')
117+
-- (fromSourceNameW name)
118+
-- (toNest $ map (fromSourceNameW . fst) constructors')
119+
-- CStruct name params givens fields defs -> do
120+
-- params' <- fromMaybeM params Empty aExplicitParams
121+
-- givens' <- aOptGivens givens
122+
-- fields' <- forM fields \(v, ty) -> (v,) <$> expr ty
123+
-- methods <- forM defs \(ann, d) -> do
124+
-- (WithSrc _ methodName, lam) <- aDef d
125+
-- return (ann, methodName, Abs (WithSrcB sid (UBindSource "self")) lam)
126+
-- return $ UStructDecl (fromSourceNameW name) (UStructDef (withoutSrc name) (givens' >>> params') fields' methods)
127+
-- CInterface name params methods -> do
128+
-- params' <- aExplicitParams params
129+
-- (methodNames, methodTys) <- unzip <$> forM methods \(methodName, ty) -> do
130+
-- ty' <- expr ty
131+
-- return (fromSourceNameW methodName, ty')
132+
-- return $ UInterface params' methodTys (fromSourceNameW name) (toNest methodNames)
133+
-- CInstanceDecl def -> aInstanceDef def
136134

137135
decl :: LetAnn -> CSDeclW -> SyntaxM (UDecl VoidS VoidS)
138136
decl ann (WithSrcs sid _ d) = WithSrcB sid <$> case d of
@@ -145,21 +143,22 @@ decl ann (WithSrcs sid _ d) = WithSrcB sid <$> case d of
145143
CExpr g -> UExprDecl <$> expr g
146144
CPass -> return UPass
147145

148-
aInstanceDef :: CInstanceDef -> SyntaxM (UTopDecl VoidS VoidS)
149-
aInstanceDef (CInstanceDef (WithSrc clNameId clName) args givens methods instNameAndParams) = do
150-
let clName' = SourceName clNameId clName
151-
args' <- mapM expr args
152-
givens' <- aOptGivens givens
153-
methods' <- catMaybes <$> mapM aMethod methods
154-
case instNameAndParams of
155-
Nothing -> return $ UInstance clName' givens' args' methods' NothingB ImplicitApp
156-
Just (WithSrc sid instName, optParams) -> do
157-
let instName' = JustB $ WithSrcB sid $ UBindSource instName
158-
case optParams of
159-
Just params -> do
160-
params' <- aExplicitParams params
161-
return $ UInstance clName' (givens' >>> params') args' methods' instName' ExplicitApp
162-
Nothing -> return $ UInstance clName' givens' args' methods' instName' ImplicitApp
146+
aInstanceDef :: CInstanceDef -> SyntaxM UTopDecl
147+
aInstanceDef = undefined
148+
-- aInstanceDef (CInstanceDef (WithSrc clNameId clName) args givens methods instNameAndParams) = do
149+
-- let clName' = SourceName clNameId clName
150+
-- args' <- mapM expr args
151+
-- givens' <- aOptGivens givens
152+
-- methods' <- catMaybes <$> mapM aMethod methods
153+
-- case instNameAndParams of
154+
-- Nothing -> return $ UInstance clName' givens' args' methods' NothingB ImplicitApp
155+
-- Just (WithSrc sid instName, optParams) -> do
156+
-- let instName' = JustB $ WithSrcB sid $ UBindSource instName
157+
-- case optParams of
158+
-- Just params -> do
159+
-- params' <- aExplicitParams params
160+
-- return $ UInstance clName' (givens' >>> params') args' methods' instName' ExplicitApp
161+
-- Nothing -> return $ UInstance clName' givens' args' methods' instName' ImplicitApp
163162

164163
aDef :: CDef -> SyntaxM (SourceNameW, ULamExpr VoidS)
165164
aDef (CDef name params optRhs optGivens body) = do

‎src/lib/ConcreteSyntax.hs

Lines changed: 2 additions & 57 deletions
Original file line numberDiff line numberDiff line change
@@ -111,35 +111,15 @@ importModule = Misc . ImportModule . OrdinaryModule <$> do
111111
WithSrc _ s <- anyCaseName
112112
eol
113113
return s
114-
115-
declareForeign :: Parser SourceBlock'
116-
declareForeign = do
117-
keyWord ForeignKW
118-
foreignName <- strLit
119-
b <- anyName
120-
void $ label "type annotation" $ sym ":"
121-
ty <- cGroup
122-
eol
123-
return $ DeclareForeign (fmap fromString foreignName) b ty
124-
125-
declareCustomLinearization :: Parser SourceBlock'
126-
declareCustomLinearization = do
127-
zeros <- (keyWord CustomLinearizationSymbolicKW $> SymbolicZeros)
128-
<|> (keyWord CustomLinearizationKW $> InstantiateZeros)
129-
fun <- anyCaseName
130-
linearization <- cGroup
131-
eol
132-
return $ DeclareCustomLinearization fun zeros linearization
133-
134114
consumeTillBreak :: Parser ()
135115
consumeTillBreak = void $ manyTill anySingle $ eof <|> void (try (eol >> eol))
136116

137117
sourceBlock' :: Parser SourceBlock'
138118
sourceBlock' =
139119
proseBlock
140-
<|> topLevelCommand
120+
<|> importModule
141121
<|> liftM TopDecl topDecl
142-
<|> topLetOrExpr <* eolf
122+
<|> liftM TopDecl topLet <* eolf
143123
<|> hidden (some eol >> return (Misc EmptyLines))
144124
<|> hidden (sc >> eol >> return (Misc CommentLine))
145125

@@ -158,15 +138,6 @@ proseBlock :: Parser SourceBlock'
158138
proseBlock = label "prose block" $
159139
char '\'' >> fmap (Misc . ProseBlock . fst) (withSource consumeTillBreak)
160140

161-
topLevelCommand :: Parser SourceBlock'
162-
topLevelCommand =
163-
importModule
164-
<|> declareForeign
165-
<|> declareCustomLinearization
166-
-- <|> (Misc . QueryEnv <$> envQuery)
167-
<|> explicitCommand
168-
<?> "top-level command"
169-
170141
_envQuery :: Parser EnvQuery
171142
_envQuery = error "not implemented"
172143
-- string ":debug" >> sc >> (
@@ -178,25 +149,6 @@ _envQuery = error "not implemented"
178149
-- rawName :: Parser RawName
179150
-- rawName = RawName <$> (fromString <$> anyName) <*> intLit
180151

181-
explicitCommand :: Parser SourceBlock'
182-
explicitCommand = do
183-
cmdName <- char ':' >> nameString
184-
cmd <- case cmdName of
185-
"p" -> return $ EvalExpr (Printed Nothing)
186-
"pp" -> return $ EvalExpr (Printed (Just PrintHaskell))
187-
"pcodegen"-> return $ EvalExpr (Printed (Just PrintCodegen))
188-
"t" -> return $ GetType
189-
"html" -> return $ EvalExpr RenderHtml
190-
"export" -> ExportFun <$> nameString
191-
_ -> fail $ "unrecognized command: " ++ show cmdName
192-
b <- cBlock <* eolf
193-
e <- case b of
194-
ExprBlock e -> return e
195-
IndentedBlock sid decls -> withSrcs $ return $ CDo $ IndentedBlock sid decls
196-
return $ case (e, cmd) of
197-
(WithSrcs sid _ (CLeaf (CIdentifier v)), GetType) -> Misc $ GetNameType (WithSrc sid v)
198-
_ -> Command cmd e
199-
200152
type CDefBody = ([(SourceNameW, GroupW)], [(LetAnn, CDef)])
201153
structDef :: Parser CTopDecl
202154
structDef = do
@@ -253,13 +205,6 @@ nameAndType = do
253205
arg <- cGroup
254206
return (n, arg)
255207

256-
topLetOrExpr :: Parser SourceBlock'
257-
topLetOrExpr = topLet >>= \case
258-
WithSrcs _ _ (CSDecl ann (CExpr e)) -> do
259-
when (ann /= PlainLet) $ fail "Cannot annotate expressions"
260-
return $ Command (EvalExpr (Printed Nothing)) e
261-
d -> return $ TopDecl d
262-
263208
topLet :: Parser CTopDeclW
264209
topLet = withSrcs do
265210
lAnn <- topLetAnn <|> return PlainLet

0 commit comments

Comments
 (0)