Move to LTS 13.7 and tidy up some repo-merge bits (#105)

gmorpheme · web-flow · commit c5fee1d890c6 · 2019-02-18T16:57:23.000Z
* Update to LTS 13.7

* LTS 13.7 &amp; tighten warnings

* More name changes to catch up with repo-merge

* Revert some WIP

* Temporary comment out WIP csv stuff
diff --git a/.gitignore b/.gitignore
@@ -1,4 +1,4 @@
 *.stack-work
 /.dir-locals.el
-/eucalypt-hs.cabal
+*.cabal
 /harness/.build
diff --git a/app/Main.hs b/app/Main.hs
@@ -5,7 +5,7 @@ import Eucalypt.Driver.Options
 import Eucalypt.Driver.Explain (explain)
 import Eucalypt.Driver.Evaluator (evaluate)
 import System.Exit
-import Paths_eucalypt_hs (version)
+import Paths_eucalypt (version)
 import Data.Version (showVersion)
 
 -- | Primary banner for version data
diff --git a/ci/release.py b/ci/release.py
@@ -60,7 +60,7 @@ def main(args):
         commit = subprocess.check_output(["git", "rev-parse", "HEAD"]).strip().decode('utf8').strip("'")
 
     # TGZ the exe
-    package = "eucalypt-hs-" + arch + ".tgz"
+    package = "eucalypt-" + arch + ".tgz"
     with tarfile.open(package, "w:gz") as tar:
         tar.add(exe_path)
 
diff --git a/package.yaml b/package.yaml
@@ -1,4 +1,4 @@
-name:                eucalypt-hs
+name:                eucalypt
 version:             0.1.1.0
 github:              "curvelogic/eucalypt"
 license:             MIT
@@ -24,6 +24,7 @@ library:
     - array
     - bound
     - bytestring
+    - cassava
     - comonad
     - conduit
     - containers
@@ -74,15 +75,15 @@ executables:
     - -rtsopts
     - -with-rtsopts=-N
     dependencies:
-    - eucalypt-hs
+    - eucalypt
     - optparse-applicative
     - directory
     - filepath
     - path
     - network-uri
 
 tests:
-  eucalypt-hs-test:
+  eucalypt-test:
     main:                Spec.hs
     source-dirs:         test
     ghc-options:
@@ -97,7 +98,7 @@ tests:
       - bytestring
       - conduit
       - containers
-      - eucalypt-hs
+      - eucalypt
       - hspec
       - hspec-megaparsec
       - libyaml
diff --git a/src/Eucalypt/Core/AnonSyn.hs b/src/Eucalypt/Core/AnonSyn.hs
@@ -7,7 +7,34 @@ Maintainer  : greg@curvelogic.co.uk
 Stability   : experimental
 -}
 
-module Eucalypt.Core.AnonSyn where
+module Eucalypt.Core.AnonSyn (
+  bif,
+  infixl_,
+  infixr_,
+  prefix_,
+  postfix_,
+  var,
+  int,
+  lam,
+  letexp,
+  letblock,
+  app,
+  soup,
+  args,
+  block,
+  str,
+  sym,
+  withMeta,
+  element,
+  corename,
+  corelist,
+  corenull,
+  corebool,
+  corelookup,
+  dynlookup,
+  unresolved,
+  Syn.CoreExpr)
+where
 
 import Eucalypt.Core.SourceMap
 import qualified Eucalypt.Core.Syn as Syn
diff --git a/src/Eucalypt/Core/Cook.hs b/src/Eucalypt/Core/Cook.hs
@@ -151,7 +151,7 @@ cookBottomUp _ e = Right e
 
 -- | Run the shunting algorithm until finished or errored
 shunt ::
-     (Show a, Anaphora SymbolicAnaphora a)
+     (Anaphora SymbolicAnaphora a)
   => State (ShuntState a) (Either CoreError (CoreExp a))
 shunt = (shunt1 `untilM_` finished) >> result
   where
diff --git a/src/Eucalypt/Core/Metadata.hs b/src/Eucalypt/Core/Metadata.hs
@@ -137,7 +137,7 @@ determineTarget meta = (, doc, format) <$> target
 
 
 
-importsFromMetadata :: ToCoreBindingName a => CoreExp a -> Maybe [Input]
+importsFromMetadata :: CoreExp a -> Maybe [Input]
 importsFromMetadata m =
   readUnevaluatedMetadata "import" m extract
   where
diff --git a/src/Eucalypt/Core/Syn.hs b/src/Eucalypt/Core/Syn.hs
@@ -517,7 +517,7 @@ isAnaphoricVar t (CoreVar _ s) = isAnaphor t s
 isAnaphoricVar _ _ = False
 
 -- | Apply a number to the unnumbered anaphor
-applyNumber :: (Anaphora t a, Eq a) => t -> a -> State Int a
+applyNumber :: (Anaphora t a) => t -> a -> State Int a
 applyNumber t s | s == unnumberedAnaphor t = do
   n <- get
   put (n + 1)
diff --git a/src/Eucalypt/Driver/Core.hs b/src/Eucalypt/Driver/Core.hs
@@ -24,6 +24,7 @@ import Control.Monad (forM_)
 import Control.Monad.Loops (iterateUntilM)
 import Control.Monad.State.Strict
 import qualified Data.ByteString as BS
+-- import qualified Data.ByteString.Lazy as BL
 import Data.Either (partitionEithers, rights)
 import Data.Foldable (toList)
 import qualified Data.Map as M
@@ -44,6 +45,7 @@ import Eucalypt.Driver.Lib (getResource)
 import Eucalypt.Driver.Options (EucalyptOptions(..))
 import Eucalypt.Reporting.Error (EucalyptError(..))
 import Eucalypt.Source.Error (DataParseException(..))
+-- import Eucalypt.Source.CsvSource
 import Eucalypt.Source.TextSource
 import Eucalypt.Source.TomlSource
 import Eucalypt.Source.YamlSource
@@ -241,6 +243,7 @@ loadUnit i@(Input locator name format) = do
       "toml" -> tomlDataToCore i source
       "yaml" -> activeYamlToCore i source
       "json" -> yamlDataToCore i source
+      -- "csv" -> csvDataToCore i source
       "eu" -> eucalyptToCore i firstSMID source
       _ -> (return . Left . Command . InvalidInput) i
   case coreUnit of
@@ -255,7 +258,8 @@ loadUnit i@(Input locator name format) = do
         Right expr ->
           (return . Right . maybeApplyName . translateToCore input smid) expr
     yamlDataToCore input text = do
-      r <- try (parseYamlExpr (show locator) text) :: IO (Either DataParseException CoreExpr)
+      r <-
+        try (parseYamlExpr (show locator) text) :: IO (Either DataParseException CoreExpr)
       case r of
         Left e -> (return . Left . Source) e
         Right core -> (return . Right . maybeApplyName . dataUnit input) core
@@ -266,15 +270,18 @@ loadUnit i@(Input locator name format) = do
       parseTomlData text >>=
       (return . Right . maybeApplyName <$> dataUnit input)
     activeYamlToCore input text = do
-      r <- try (parseYamlExpr (show locator) text) :: IO (Either DataParseException CoreExpr)
+      r <-
+        try (parseYamlExpr (show locator) text) :: IO (Either DataParseException CoreExpr)
       case r of
         Left e -> (return . Left . Source) e
         Right core -> (return . Right . maybeApplyName . dataUnit input) core
-
+    -- csvDataToCore input text =
+    --   parseCsv (BL.fromStrict text) >>=
+    --   (return . Right . maybeApplyName <$> dataUnit input)
 
 
 -- | Parse units, reporting and exiting on error
-loadUnits :: (Traversable t, Foldable t) => t Input -> CoreLoad [TranslationUnit]
+loadUnits :: Traversable t => t Input -> CoreLoad [TranslationUnit]
 loadUnits inputs = do
   asts <- traverse loadUnit inputs
   case partitionEithers (toList asts) of
diff --git a/src/Eucalypt/Driver/Stg.hs b/src/Eucalypt/Driver/Stg.hs
@@ -65,7 +65,7 @@ debugMachine = initDebugMachineState
 
 -- | Useful for comparing speed of conduit render pipelines with raw
 --  evaluation.
-runHeadless :: (MonadUnliftIO m, MonadIO m, MonadThrow m, MonadCatch m)
+runHeadless :: (MonadUnliftIO m, MonadCatch m)
   => EucalyptOptions
   -> CoreExpr
   -> m ()
@@ -92,7 +92,7 @@ runHeadless opts expr = do
 -- | Build a conduit streaming pipeline where the machine generates
 -- events and renderer processes them.
 renderConduit ::
-     (MonadUnliftIO m, MonadIO m, MonadThrow m, MonadCatch m)
+     (MonadUnliftIO m, MonadCatch m)
   => EucalyptOptions
   -> CoreExpr
   -> m BS.ByteString
@@ -114,7 +114,7 @@ renderConduit opts expr = handle handler $ do
 -- | Step through the machine yielding events via the conduit pipeline
 -- at each stage
 machineSource ::
-     (MonadUnliftIO m, MonadResource m, MonadIO m, MonadThrow m)
+     (MonadUnliftIO m, MonadThrow m)
   => MachineState
   -> ConduitT () Event m ()
 machineSource ms = do
diff --git a/src/Eucalypt/Source/Error.hs b/src/Eucalypt/Source/Error.hs
@@ -25,6 +25,7 @@ data DataParseException
   | YamlParseError !String !String !String !Int !Int
   | FromYamlException Text
   | FromTomlException Text
+  | FromCsvException Text
   deriving (Eq, Typeable)
 
 instance Show DataParseException where
@@ -34,6 +35,7 @@ instance Show DataParseException where
   show (YamlParseError msg ctxt locator _line _col)  = locator ++ ": " ++ msg ++ " " ++ ctxt
   show (FromYamlException ye) = "Error reading YAML: " ++ unpack ye
   show (FromTomlException te) = "Error reading TOML: " ++ unpack te
+  show (FromCsvException te) = "Error reading CSV: " ++ unpack te
 
 instance Exception DataParseException
 
diff --git a/src/Eucalypt/Source/YamlSource.hs b/src/Eucalypt/Source/YamlSource.hs
@@ -39,15 +39,15 @@ data RawExpr =
 -- | A scheme for translating YAML into Eucalypt core syntax
 class YamlTranslator a where
   handleScalar ::
-       (Monad m, MonadThrow m)
+       (MonadThrow m)
     => a
     -> BS.ByteString
     -> Tag
     -> Style
     -> Anchor
     -> m CoreExpr
   handleList ::
-       (Monad m, MonadThrow m)
+       (MonadThrow m)
     => a
     -> [CoreExpr]
     -> Tag
@@ -58,7 +58,7 @@ class YamlTranslator a where
   -- | Called to translate a mapping, with binding names, key
   -- expression and value expressions
   handleMapping ::
-       (Monad m, MonadThrow m)
+       (MonadThrow m)
     => a
     -> [(Text, CoreExpr, CoreExpr)]
     -> Tag
@@ -110,7 +110,7 @@ parseBool _ = False
 -- @
 -- x: !eu 25 * 23
 -- @
-expressionFromString :: (Monad m, MonadThrow m) => String -> m CoreExpr
+expressionFromString :: MonadThrow m => String -> m CoreExpr
 expressionFromString s =
   case parseExpression s "YAML embedding" of
     Left err -> throwM err
@@ -123,7 +123,7 @@ expressionFromString s =
 -- @
 -- x: !eu::fn (x, y, z) x + y + z
 -- @
-lambdaExpressionFromString :: (Monad m, MonadThrow m) => String -> m CoreExpr
+lambdaExpressionFromString :: MonadThrow m => String -> m CoreExpr
 lambdaExpressionFromString s =
   case parseLambda s "YAML embedded function" of
     Left err -> throwM err
diff --git a/src/Eucalypt/Stg/Compiler/CompileCore.hs b/src/Eucalypt/Stg/Compiler/CompileCore.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 {-# LANGUAGE RecursiveDo #-}
 {-|
 Module      : Eucalypt.Stg.Compiler.CompileCore
diff --git a/src/Eucalypt/Stg/Eval.hs b/src/Eucalypt/Stg/Eval.hs
@@ -135,7 +135,7 @@ applyOver ms _ref arity cs env le lf xs =
 
 -- | Partially apply closure when we have too few arguments
 applyUnder ::
-     (MonadIO m, MonadThrow m)
+     (MonadIO m)
   => MachineState
   -> Address
   -> ValVec
@@ -191,7 +191,7 @@ applyPartialOver ms arity cs env args le lf xs =
 
 -- | Partially apply closure when we have too few arguments
 applyPartialUnder ::
-     (MonadIO m, MonadThrow m)
+     (MonadIO m)
   => MachineState
   -> Address
   -> ValVec
diff --git a/src/Eucalypt/Stg/Intrinsics/Common.hs b/src/Eucalypt/Stg/Intrinsics/Common.hs
@@ -109,8 +109,9 @@ readNatListReturn :: MachineState -> IO [Native]
 readNatListReturn ms =
   case ms of
     MachineState {machineCode = (ReturnCon TagCons xs Nothing)} ->
-      let (StgNat h _ :< (StgAddr t :< _)) = asSeq xs
-       in (h :) <$> readNatList ms t
+      case asSeq xs of
+        (StgNat h _ :< (StgAddr t :< _)) -> (h :) <$> readNatList ms t
+        _ -> throwIn ms IntrinsicExpectedNativeList
     MachineState {machineCode = (ReturnCon TagNil _ Nothing)} -> return []
     _ -> throwIn ms IntrinsicExpectedNativeList
 
diff --git a/src/Eucalypt/Stg/Intrinsics/Emit.hs b/src/Eucalypt/Stg/Intrinsics/Emit.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-|
@@ -90,7 +91,7 @@ getValue ms a k = do
 -- (representing metadata) excavate out a native value for the
 -- specified key.
 --
--- Gruesome.
+-- Gruesome. TODO: incomplete uni patterns
 excavate :: MachineState -> Symbol -> Address -> IO (Maybe Native)
 excavate ms k a = do
   obj <- peek a
diff --git a/src/Eucalypt/Stg/Scrapers.hs b/src/Eucalypt/Stg/Scrapers.hs
@@ -56,12 +56,14 @@ instance Scrapeable a => Scrapeable [a] where
     obj <- peek addr
     case obj of
       Closure { closureEnv = e
-              , closureCode = LambdaForm {lamBody = (App (Con TagCons) xs)}
-              } -> do
-        let (h :< (t :< _)) = asSeq $ values (e, ms) $ nativeToValue <$> xs
-        h' <- scrape ms h :: IO (Maybe a)
-        t' <- scrape ms t :: IO (Maybe [a])
-        return $ (:) <$> h' <*> t'
+              , closureCode = LambdaForm {lamBody = expr@(App (Con TagCons) xs)}
+              } ->
+        case asSeq $ values (e, ms) $ nativeToValue <$> xs of
+          (h :< (t :< _)) -> do
+            h' <- scrape ms h :: IO (Maybe a)
+            t' <- scrape ms t :: IO (Maybe [a])
+            return $ (:) <$> h' <*> t'
+          _ -> throwIn ms $ IntrinsicExpectedEvaluatedList expr
       Closure {closureCode = LambdaForm {lamBody = (App (Con TagNil) _)}} ->
         return $ Just []
       Closure {closureCode = lf} ->
@@ -76,14 +78,16 @@ instance (Scrapeable k, Scrapeable v) => Scrapeable (k, v) where
     obj <- peek addr
     case obj of
       Closure { closureEnv = e
-              , closureCode = LambdaForm {lamBody = (App (Con TagCons) xs)}
-              } -> do
-        let (h :< (t :< _)) = asSeq $ values (e, ms) $ nativeToValue <$> xs
-        k <- scrape ms h :: IO (Maybe k)
-        t' <- scrape ms t :: IO (Maybe [v])
-        case t' of
-          (Just (v:_)) -> return $ (,) <$> k <*> Just v
-          _ -> throwIn ms IntrinsicBadPair
+              , closureCode = LambdaForm {lamBody = expr@(App (Con TagCons) xs)}
+              } ->
+        case asSeq $ values (e, ms) $ nativeToValue <$> xs of
+          (h :< (t :< _)) -> do
+            k <- scrape ms h :: IO (Maybe k)
+            t' <- scrape ms t :: IO (Maybe [v])
+            case t' of
+              (Just (v:_)) -> return $ (,) <$> k <*> Just v
+              _ -> throwIn ms IntrinsicBadPair
+          _ -> throwIn ms $ IntrinsicExpectedEvaluatedList expr
       Closure {closureCode = lf} ->
         throwIn ms $ IntrinsicExpectedEvaluatedList (lamBody lf)
       BlackHole -> throwIn ms IntrinsicExpectedListFoundBlackHole
@@ -105,11 +109,13 @@ instance Scrapeable k => Scrapeable (BareCons k) where
     obj <- peek addr
     case obj of
       Closure { closureEnv = e
-              , closureCode = LambdaForm {lamBody = (App (Con TagCons) xs)}
-              } -> do
-        let (h :< (t :< _)) = asSeq $ values (e, ms) $ nativeToValue <$> xs
-        k <- scrape ms h
-        return $ BareCons <$> k <*> pure t
+              , closureCode = LambdaForm {lamBody = expr@(App (Con TagCons) xs)}
+              } ->
+        case asSeq $ values (e, ms) $ nativeToValue <$> xs of
+          (h :< (t :< _)) -> do
+            k <- scrape ms h
+            return $ BareCons <$> k <*> pure t
+          _ -> throwIn ms $ IntrinsicExpectedEvaluatedList expr
       Closure {closureCode = lf} ->
         throwIn ms $ IntrinsicExpectedEvaluatedList (lamBody lf)
       BlackHole -> throwIn ms IntrinsicExpectedListFoundBlackHole
diff --git a/stack.yaml b/stack.yaml
@@ -1,5 +1,5 @@
-resolver: lts-13.2
+resolver: lts-13.7
 packages:
 - '.'
 ghc-options:
-  eucalypt-hs: -Wall -Werror
+  eucalypt: -Wall -Werror -Wincomplete-uni-patterns -Wredundant-constraints
diff --git a/test/Eucalypt/Stg/Intrinsics/CommonSpec.hs b/test/Eucalypt/Stg/Intrinsics/CommonSpec.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-|
 Module      : Eucalypt.Stg.Intrinsics.CommonSpec
