Controlled burn

dex.cabal

@@ -41,19 +41,19 @@ flag debug
 
 library
   exposed-modules:     AbstractSyntax
-                     , Builder
-                     , CUDA
-                     , CheapReduction
+                     -- , Builder
+                     -- , CUDA
+                     -- , CheapReduction
                      -- , CheckType
                      , ConcreteSyntax
-                     , Core
-                     , DPS
+                     -- , Core
+                     -- , DPS
                      , Err
-                     , Generalize
-                     , Imp
-                     , ImpToLLVM
+                     -- , Generalize
+                     -- , Imp
+                     -- , ImpToLLVM
                      , IncState
-                     , Inference
+                     -- , Inference
                      -- , Inline
                      -- , JAX.Concrete
                      -- , JAX.Rename
@@ -73,29 +73,29 @@ library
                      -- , PeepholeOptimize
                      , PPrint
                      , RawName
-                     , Runtime
+                     -- , Runtime
                      -- , RuntimePrint
-                     , Serialize
-                     , Simplify
-                     , Subst
+                     -- , Serialize
+                     -- , Simplify
+                     -- , Subst
                      , SourceRename
                      , SourceIdTraversal
-                     , TopLevel
+                     , TopLevel2
                      -- , Transpose
                      , Types.Simple
                      , Types.Complicated
                      , Types.Imp
                      , Types.Primitives
                      , Types.Source
-                     , Types.Top
-                     , QueryType
-                     , QueryTypePure
+                     , Types.Top2
+                     -- , QueryType
+                     -- , QueryTypePure
                      , Util
                      -- , Vectorize
                      , Actor
-                     , Live.Eval
-                     , Live.Web
-                     , RenderHtml
+                     -- , Live.Eval
+                     -- , Live.Web
+                     -- , RenderHtml
   other-modules:       Paths_dex
   build-depends:       base
                      , bytestring

src/dex.hs

@@ -19,15 +19,12 @@ import qualified Data.Map.Strict as M
 import qualified System.Console.ANSI as ANSI
 import System.Console.ANSI hiding (Color)
 
-import TopLevel
+import Types.Source
+import TopLevel2
 import AbstractSyntax (parseTopDeclRepl)
 import ConcreteSyntax (keyWordStrs, preludeImportBlock)
-import Live.Web
+-- import Live.Web
 import PPrint  hiding (hardline)
-import Core
-import Types.Imp
-import Types.Source
-import Types.Top
 import MonadUtil
 import Util (readFileText)
 
@@ -45,43 +42,44 @@ data CmdOpts = CmdOpts EvalMode EvalConfig
 runMode :: CmdOpts -> IO ()
 runMode (CmdOpts evalMode cfg) = case evalMode of
   ScriptMode fname fmt -> do
-    env <- loadCache
+    env <- initTopState -- loadCache
     ((), finalEnv) <- runTopperM cfg stdOutLogger env do
       blocks <- parseSourceBlocks <$> readFileText fname
       forM_ blocks \block -> do
         case fmt of
           ResultOnly -> return ()
           TextDoc    -> liftIO $ putStr $ pprint block
         evalSourceBlockRepl block
-    storeCache finalEnv
-  ReplMode -> do
-    env <- loadCache
-    void $ runTopperM cfg stdOutLogger env do
-      void $ evalSourceBlockRepl preludeImportBlock
-      forever do
-         block <- readSourceBlock
-         void $ evalSourceBlockRepl block
-  WebMode    fname -> do
-    env <- loadCache
-    runWeb fname cfg env
-  GenerateHTML fname dest -> do
-    env <- loadCache
-    generateHTML fname dest cfg env
-  ClearCache -> clearCache
+    return ()
+    -- storeCache finalEnv
+  -- ReplMode -> do
+  --   env <- loadCache
+  --   void $ runTopperM cfg stdOutLogger env do
+  --     void $ evalSourceBlockRepl preludeImportBlock
+  --     forever do
+  --        block <- readSourceBlock
+  --        void $ evalSourceBlockRepl block
+  -- WebMode    fname -> do
+  --   env <- loadCache
+  --   runWeb fname cfg env
+  -- GenerateHTML fname dest -> do
+  --   env <- loadCache
+  --   generateHTML fname dest cfg env
+  -- ClearCache -> clearCache
 
 stdOutLogger :: Outputs -> IO ()
 stdOutLogger (Outputs outs) = do
   isatty <- queryTerminal stdOutput
   forM_ outs \out -> putStr $ printOutput isatty out
 
-readSourceBlock :: (MonadIO (m n), EnvReader m) => m n SourceBlock
-readSourceBlock = do
-  sourceMap <- withEnv $ envSourceMap . moduleEnv
-  let filenameAndDexCompletions =
-        completeQuotedWord (Just '\\') "\"'" listFiles (dexCompletions sourceMap)
-  let hasklineSettings = setComplete filenameAndDexCompletions defaultSettings
-  liftIO $ runInputT hasklineSettings $ readMultiline prompt (parseTopDeclRepl . T.pack)
-  where prompt = ">=> "
+-- readSourceBlock :: MonadIO (m n) => m n SourceBlock
+-- readSourceBlock = do
+--   sourceMap <- withEnv $ envSourceMap . moduleEnv
+--   let filenameAndDexCompletions =
+--         completeQuotedWord (Just '\\') "\"'" listFiles (dexCompletions sourceMap)
+--   let hasklineSettings = setComplete filenameAndDexCompletions defaultSettings
+--   liftIO $ runInputT hasklineSettings $ readMultiline prompt (parseTopDeclRepl . T.pack)
+--   where prompt = ">=> "
 
 dexCompletions :: Monad m => SourceMap n -> CompletionFunc m
 dexCompletions sourceMap (line, _) = do
@@ -145,8 +143,7 @@ enumOption optName prettyOptName defaultVal options = option
 
 parseEvalOpts :: Parser EvalConfig
 parseEvalOpts = EvalConfig
-  <$> enumOption "backend" "Backend" LLVM backends
-  <*> (option pathOption $ long "lib-path" <> value [LibBuiltinPath]
+  <$> (option pathOption $ long "lib-path" <> value [LibBuiltinPath]
     <> metavar "PATH" <> help "Library path")
   <*> optional (strOption $ long "prelude" <> metavar "FILE" <> help "Prelude file")
   <*> flag NoOptimize Optimize (short 'O' <> help "Optimize generated code")
@@ -155,8 +152,6 @@ parseEvalOpts = EvalConfig
   where
     printBackends = [ ("haskell", PrintHaskell)
                     , ("dex"    , PrintCodegen) ]
-    backends = [ ("llvm"   , LLVM  )
-               , ("llvm-mc", LLVMMC) ]
     logLevels = [ ("normal", NormalLogLevel)
                 , ("debug" , DebugLogLevel ) ]
 

src/lib/AbstractSyntax.hs

@@ -69,7 +69,7 @@ import Util
 parseExpr :: Fallible m => GroupW -> m (UExpr VoidS)
 parseExpr e = liftSyntaxM $ expr e
 
-parseDecl :: Fallible m => CTopDeclW -> m (UTopDecl VoidS VoidS)
+parseDecl :: Fallible m => CTopDeclW -> m UTopDecl
 parseDecl d = liftSyntaxM $ topDecl d
 
 parseBlock :: Fallible m => CSBlock -> m (UBlock VoidS)
@@ -93,46 +93,44 @@ checkSourceBlockParses = \case
     when (ann /= PlainLet) $ fail "Cannot annotate expressions"
     void $ expr e
   TopDecl d -> void $ topDecl d
-  Command _ b -> void $ expr b
-  DeclareForeign _ _ ty -> void $ expr ty
-  DeclareCustomLinearization _ _ body -> void $ expr body
   Misc _ -> return ()
   UnParseable _ _ -> return ()
 
 -- === Converting concrete syntax to abstract syntax ===
 
 type SyntaxM = Except
 
-topDecl :: CTopDeclW -> SyntaxM (UTopDecl VoidS VoidS)
-topDecl (WithSrcs sid sids topDecl') = case topDecl' of
-  CSDecl ann d -> ULocalDecl <$> decl ann (WithSrcs sid sids d)
-  CData name tyConParams givens constructors -> do
-    tyConParams' <- fromMaybeM tyConParams Empty aExplicitParams
-    givens' <- aOptGivens givens
-    constructors' <- forM constructors \(v, ps) -> do
-      ps' <- fromMaybeM ps Empty \(WithSrcs _ _ ps') ->
-        toNest <$> mapM (tyOptBinder Explicit) ps'
-      return (v, ps')
-    return $ UDataDefDecl
-      (UDataDef (withoutSrc name) (givens' >>> tyConParams') $
-        map (\(name', cons) -> (withoutSrc name', UDataDefTrail cons)) constructors')
-      (fromSourceNameW name)
-      (toNest $ map (fromSourceNameW . fst) constructors')
-  CStruct name params givens fields defs -> do
-    params' <- fromMaybeM params Empty aExplicitParams
-    givens' <- aOptGivens givens
-    fields' <- forM fields \(v, ty) -> (v,) <$> expr ty
-    methods <- forM defs \(ann, d) -> do
-      (WithSrc _ methodName, lam) <- aDef d
-      return (ann, methodName, Abs (WithSrcB sid (UBindSource "self")) lam)
-    return $ UStructDecl (fromSourceNameW name) (UStructDef (withoutSrc name) (givens' >>> params') fields' methods)
-  CInterface name params methods -> do
-    params' <- aExplicitParams params
-    (methodNames, methodTys) <- unzip <$> forM methods \(methodName, ty) -> do
-      ty' <- expr ty
-      return (fromSourceNameW methodName, ty')
-    return $ UInterface params' methodTys (fromSourceNameW name) (toNest methodNames)
-  CInstanceDecl def -> aInstanceDef def
+topDecl :: CTopDeclW -> SyntaxM UTopDecl
+topDecl (WithSrcs sid sids topDecl') = undefined
+-- topDecl (WithSrcs sid sids topDecl') = case topDecl' of
+--   CSDecl ann d -> UTopLet <$> decl ann (WithSrcs sid sids d)
+--   CData name tyConParams givens constructors -> do
+--     tyConParams' <- fromMaybeM tyConParams Empty aExplicitParams
+--     givens' <- aOptGivens givens
+--     constructors' <- forM constructors \(v, ps) -> do
+--       ps' <- fromMaybeM ps Empty \(WithSrcs _ _ ps') ->
+--         toNest <$> mapM (tyOptBinder Explicit) ps'
+--       return (v, ps')
+--     return $ UDataDefDecl
+--       (UDataDef (withoutSrc name) (givens' >>> tyConParams') $
+--         map (\(name', cons) -> (withoutSrc name', UDataDefTrail cons)) constructors')
+--       (fromSourceNameW name)
+--       (toNest $ map (fromSourceNameW . fst) constructors')
+--   CStruct name params givens fields defs -> do
+--     params' <- fromMaybeM params Empty aExplicitParams
+--     givens' <- aOptGivens givens
+--     fields' <- forM fields \(v, ty) -> (v,) <$> expr ty
+--     methods <- forM defs \(ann, d) -> do
+--       (WithSrc _ methodName, lam) <- aDef d
+--       return (ann, methodName, Abs (WithSrcB sid (UBindSource "self")) lam)
+--     return $ UStructDecl (fromSourceNameW name) (UStructDef (withoutSrc name) (givens' >>> params') fields' methods)
+--   CInterface name params methods -> do
+--     params' <- aExplicitParams params
+--     (methodNames, methodTys) <- unzip <$> forM methods \(methodName, ty) -> do
+--       ty' <- expr ty
+--       return (fromSourceNameW methodName, ty')
+--     return $ UInterface params' methodTys (fromSourceNameW name) (toNest methodNames)
+--   CInstanceDecl def -> aInstanceDef def
 
 decl :: LetAnn -> CSDeclW -> SyntaxM (UDecl VoidS VoidS)
 decl ann (WithSrcs sid _ d) = WithSrcB sid <$> case d of
@@ -145,21 +143,22 @@ decl ann (WithSrcs sid _ d) = WithSrcB sid <$> case d of
   CExpr g -> UExprDecl <$> expr g
   CPass -> return UPass
 
-aInstanceDef :: CInstanceDef -> SyntaxM (UTopDecl VoidS VoidS)
-aInstanceDef (CInstanceDef (WithSrc clNameId clName) args givens methods instNameAndParams) = do
-  let clName' = SourceName clNameId clName
-  args' <- mapM expr args
-  givens' <- aOptGivens givens
-  methods' <- catMaybes <$> mapM aMethod methods
-  case instNameAndParams of
-    Nothing -> return $ UInstance clName' givens' args' methods' NothingB ImplicitApp
-    Just (WithSrc sid instName, optParams) -> do
-      let instName' = JustB $ WithSrcB sid $ UBindSource instName
-      case optParams of
-        Just params -> do
-          params' <- aExplicitParams params
-          return $ UInstance clName' (givens' >>> params') args' methods' instName' ExplicitApp
-        Nothing -> return $ UInstance clName' givens' args' methods' instName' ImplicitApp
+aInstanceDef :: CInstanceDef -> SyntaxM UTopDecl
+aInstanceDef = undefined
+-- aInstanceDef (CInstanceDef (WithSrc clNameId clName) args givens methods instNameAndParams) = do
+--   let clName' = SourceName clNameId clName
+--   args' <- mapM expr args
+--   givens' <- aOptGivens givens
+--   methods' <- catMaybes <$> mapM aMethod methods
+--   case instNameAndParams of
+--     Nothing -> return $ UInstance clName' givens' args' methods' NothingB ImplicitApp
+--     Just (WithSrc sid instName, optParams) -> do
+--       let instName' = JustB $ WithSrcB sid $ UBindSource instName
+--       case optParams of
+--         Just params -> do
+--           params' <- aExplicitParams params
+--           return $ UInstance clName' (givens' >>> params') args' methods' instName' ExplicitApp
+--         Nothing -> return $ UInstance clName' givens' args' methods' instName' ImplicitApp
 
 aDef :: CDef -> SyntaxM (SourceNameW, ULamExpr VoidS)
 aDef (CDef name params optRhs optGivens body) = do

src/lib/ConcreteSyntax.hs

@@ -111,35 +111,15 @@ importModule = Misc . ImportModule . OrdinaryModule <$> do
   WithSrc _ s <- anyCaseName
   eol
   return s
-
-declareForeign :: Parser SourceBlock'
-declareForeign = do
-  keyWord ForeignKW
-  foreignName <- strLit
-  b <- anyName
-  void $ label "type annotation" $ sym ":"
-  ty <- cGroup
-  eol
-  return $ DeclareForeign (fmap fromString foreignName) b ty
-
-declareCustomLinearization :: Parser SourceBlock'
-declareCustomLinearization = do
-  zeros <- (keyWord CustomLinearizationSymbolicKW $> SymbolicZeros)
-       <|> (keyWord CustomLinearizationKW $> InstantiateZeros)
-  fun <- anyCaseName
-  linearization <- cGroup
-  eol
-  return $ DeclareCustomLinearization fun zeros linearization
-
 consumeTillBreak :: Parser ()
 consumeTillBreak = void $ manyTill anySingle $ eof <|> void (try (eol >> eol))
 
 sourceBlock' :: Parser SourceBlock'
 sourceBlock' =
       proseBlock
-  <|> topLevelCommand
+  <|> importModule
   <|> liftM TopDecl topDecl
-  <|> topLetOrExpr <* eolf
+  <|> liftM TopDecl topLet <* eolf
   <|> hidden (some eol >> return (Misc EmptyLines))
   <|> hidden (sc >> eol >> return (Misc CommentLine))
 
@@ -158,15 +138,6 @@ proseBlock :: Parser SourceBlock'
 proseBlock = label "prose block" $
   char '\'' >> fmap (Misc . ProseBlock . fst) (withSource consumeTillBreak)
 
-topLevelCommand :: Parser SourceBlock'
-topLevelCommand =
-      importModule
-  <|> declareForeign
-  <|> declareCustomLinearization
-  -- <|> (Misc . QueryEnv <$> envQuery)
-  <|> explicitCommand
-  <?> "top-level command"
-
 _envQuery :: Parser EnvQuery
 _envQuery = error "not implemented"
 -- string ":debug" >> sc >> (
@@ -178,25 +149,6 @@ _envQuery = error "not implemented"
 --     rawName :: Parser RawName
 --     rawName = RawName <$> (fromString <$> anyName) <*> intLit
 
-explicitCommand :: Parser SourceBlock'
-explicitCommand = do
-  cmdName <- char ':' >> nameString
-  cmd <- case cmdName of
-    "p"       -> return $ EvalExpr (Printed Nothing)
-    "pp"      -> return $ EvalExpr (Printed (Just PrintHaskell))
-    "pcodegen"-> return $ EvalExpr (Printed (Just PrintCodegen))
-    "t"       -> return $ GetType
-    "html"    -> return $ EvalExpr RenderHtml
-    "export"  -> ExportFun <$> nameString
-    _ -> fail $ "unrecognized command: " ++ show cmdName
-  b <- cBlock <* eolf
-  e <- case b of
-    ExprBlock e -> return e
-    IndentedBlock sid decls -> withSrcs $ return $ CDo $ IndentedBlock sid decls
-  return $ case (e, cmd) of
-    (WithSrcs sid _ (CLeaf (CIdentifier v)), GetType) -> Misc $ GetNameType (WithSrc sid v)
-    _ -> Command cmd e
-
 type CDefBody = ([(SourceNameW, GroupW)], [(LetAnn, CDef)])
 structDef :: Parser CTopDecl
 structDef = do
@@ -253,13 +205,6 @@ nameAndType = do
   arg <- cGroup
   return (n, arg)
 
-topLetOrExpr :: Parser SourceBlock'
-topLetOrExpr = topLet >>= \case
-  WithSrcs _ _ (CSDecl ann (CExpr e)) -> do
-    when (ann /= PlainLet) $ fail "Cannot annotate expressions"
-    return $ Command (EvalExpr (Printed Nothing)) e
-  d -> return $ TopDecl d
-
 topLet :: Parser CTopDeclW
 topLet = withSrcs do
   lAnn <- topLetAnn <|> return PlainLet