Use Data.Sum instead of manual Union

tools/lsp/squirrel/package.yaml

@@ -9,6 +9,7 @@ dependencies:
   - template-haskell
   - text
   - tree-sitter
+  - fastsum
 
 default-extensions:
   - BangPatterns

tools/lsp/squirrel/src/AST/Parser.hs

@@ -2,21 +2,21 @@
 {- | Parser for a contract.
 -}
 
-module AST.Parser ({-example,-} contract) where
+module AST.Parser (example, contract) where
 
 import Data.Text (Text)
+import Data.Sum
 
 import AST.Types
 
 import Parser
 import Tree hiding (skip)
-import Union
 
 -- import Debug.Trace
 
 ranged
   :: ( Functor f
-     , Member  f fs
+     , Element f fs
      )
   => Parser (f (Tree fs ASTInfo))
   -> Parser    (Tree fs ASTInfo)
@@ -858,7 +858,7 @@ typeTuple = do
 -- example = "../../../src/test/contracts/bytes_arithmetic.ligo"
 -- example = "../../../src/test/contracts/bytes_unpack.ligo"
 -- example = "../../../src/test/contracts/chain_id.ligo"
--- example = "../../../src/test/contracts/coase.ligo"
+example = "../../../src/test/contracts/coase.ligo"
 -- example = "../../../src/test/contracts/failwith.ligo"
 -- example = "../../../src/test/contracts/loop.ligo"
 -- example = "../../../src/test/contracts/application.ligo"

tools/lsp/squirrel/src/Pretty.hs

@@ -29,6 +29,8 @@ module Pretty
   )
   where
 
+import Data.Sum
+
 import qualified Data.Text as Text
 import Data.Text (Text, pack)
 
@@ -52,6 +54,12 @@ class Pretty p where
 class Pretty1 p where
   pp1 :: p Doc -> Doc
 
+instance Pretty1 (Sum '[]) where
+  pp1 = error "Sum.empty"
+
+instance (Pretty1 f, Pretty1 (Sum fs)) => Pretty1 (Sum (f : fs)) where
+  pp1 = either pp1 pp1 . decompose
+
 instance Pretty () where
   pp _ = "-"
 

tools/lsp/squirrel/src/Tree.hs

@@ -23,7 +23,8 @@ module Tree
   )
   where
 
-import Union
+import Data.Sum
+
 import Lattice
 import Comment
 import Pretty
@@ -36,25 +37,25 @@ import Error
 --   Can contain `Error` instead of all the above.
 --
 newtype Tree layers info = Tree
-  { unTree :: Either (Error info) (info, Union layers (Tree layers info))
+  { unTree :: Either (Error info) (info, Sum layers (Tree layers info))
   }
 
-instance (Functor (Union layers)) => Functor (Tree layers) where
+instance Apply Functor layers => Functor (Tree layers) where
   fmap f = go
     where
       go (Tree (Left   err))      = Tree $ Left $ fmap f err
       go (Tree (Right (a, rest))) = Tree $ Right (f a, fmap go rest)
 
-instance (Functor (Union layers), Foldable (Union layers)) => Foldable (Tree layers) where
+instance Apply Foldable layers => Foldable (Tree layers) where
   foldMap f = go
     where
       go (Tree (Left   err))      = foldMap f err
       go (Tree (Right (a, rest))) = f a <> foldMap go rest
 
 instance
-    ( Functor    (Union layers)
+    ( Apply Functor layers
     , HasComments info
-    , Pretty1    (Union layers)
+    , Pretty1    (Sum layers)
     , Pretty      info
     )
   =>
@@ -64,8 +65,8 @@ instance
 
 instance {-# OVERLAPS #-}
     ( HasComments info
-    , Functor    (Union fs)
+    , Apply Functor fs
-    , Pretty1    (Union fs)
+    , Pretty1    (Sum fs)
     , Pretty      info
     )
   =>
@@ -79,7 +80,7 @@ instance {-# OVERLAPS #-}
 -- | Return all subtrees that cover the range, ascending in size.
 spineTo
   :: ( Lattice   info
-     , Foldable (Union fs)
+     , Apply Foldable fs
      )
   => info
   -> Tree fs info
@@ -98,8 +99,10 @@ spineTo info = reverse . go
 --   For each tree piece, will call `before` and `after` callbacks.
 --
 traverseTree
-  :: ( UpdateOver m (Union fs) (Tree fs a)
+  :: ( UpdateOver m (Sum fs) (Tree fs a)
-     , Traversable  (Union fs)
+     , Apply Foldable fs
+     , Apply Functor fs
+     , Apply Traversable fs
      )
   => (a -> m b) -> Tree fs a -> m (Tree fs b)
 traverseTree act = go
@@ -116,8 +119,8 @@ traverseTree act = go
       return (Tree (Left err'))
 
 -- | Make a tree out of a layer and an info.
-mk :: (Functor f, Member f fs) => info -> f (Tree fs info) -> Tree fs info
+mk :: (Functor f, Element f fs) => info -> f (Tree fs info) -> Tree fs info
-mk i fx = Tree $ Right (i, inj fx)
+mk i fx = Tree $ Right (i, inject fx)
 
 -- | Get info from the tree.
 infoOf :: Tree fs info -> info
@@ -126,7 +129,7 @@ infoOf = either eInfo fst . unTree
 instance Stubbed (Tree fs info) info where
   stub = Tree . Left
 
-instance Foldable (Union fs) => HasErrors (Tree fs info) info where
+instance Apply Foldable fs => HasErrors (Tree fs info) info where
   errors = go
     where
       go (Tree (Left   err))      = pure err
@@ -144,10 +147,10 @@ class Monad m => UpdateOver m f a where
 skip :: Monad m => m ()
 skip = return ()
 
-instance Monad m => UpdateOver m (Union '[]) a where
+instance Monad m => UpdateOver m (Sum '[]) a where
-  before = error "Union.empty"
+  before = error "Sum.empty"
-  after  = error "Union.empty"
+  after  = error "Sum.empty"
 
-instance (UpdateOver m f a, UpdateOver m (Union fs) a) => UpdateOver m (Union (f : fs)) a where
+instance (UpdateOver m f a, UpdateOver m (Sum fs) a) => UpdateOver m (Sum (f : fs)) a where
-  before = eliminate before before
+  before = either before before . decompose
-  after  = eliminate after  after
+  after  = either after  after  . decompose

tools/lsp/squirrel/src/Union.hs

@@ -1,115 +0,0 @@
-
-{- | The union of functors and utilities.
-
--}
-
-module Union
-  ( -- * Union type
-    Union
-  , eliminate
-
-    -- * Interface
-  , Member
-  , proj
-  , inj
-  )
-  where
-
-import Data.Kind
-import Data.Function (on)
-
-import GHC.Exts
-import GHC.TypeLits
-
-import Unsafe.Coerce
-
-import Pretty
-
--- | The "one of" datatype.
---
---   Each @Union fs a@ is a @f a@, where @f@ is one of @fs@`.
-data Union (fs :: [* -> *]) x where
-  MkUnion :: Integer -> Any fs x -> Union fs x
-
-type family Find (f :: * -> *) fs :: Nat where
-  Find f  (f : _)  = 0
-  Find f  (_ : fs) = 1 + Find f fs
-
-type family Len (fs :: [* -> *]) :: Nat where
-  Len '[]  = 0
-  Len  (_ : fs) = 1 + Len fs
-
-type Member f fs = KnownNat (Find f fs)
-type KnownList fs = KnownNat (Len fs)
-
-val :: forall n. KnownNat n => Integer
-val = natVal' (proxy# :: Proxy# n)
-
-inj
-  :: forall f fs n x
-  .  ( n ~ Find f fs
-     , KnownNat n
-     )
-  => f x
-  -> Union fs x
-inj fx = MkUnion (val @n) (unsafeCoerce fx)
-
-raise
-  :: Union fs x
-  -> Union (f : fs) x
-raise (MkUnion i b) = MkUnion (i + 1) (unsafeCoerce b)
-
-proj
-  :: forall f fs n x
-  .  ( n ~ Find f fs
-     , KnownNat n
-     )
-  => Union fs x
-  -> Maybe (f x)
-proj (MkUnion i body)
-  | i == val @n = Just $ unsafeCoerce body
-  | otherwise   = Nothing
-
-split
-  :: Union (f : fs) x
-  -> Either (f x) (Union fs x)
-split = eliminate Left Right
-
-vacuum :: Union '[] a -> b
-vacuum = error "Empty union"
-
--- | A case-split over `Union`.
-eliminate
-  :: (f x -> a)
-  -> (Union fs x -> a)
-  -> (Union (f : fs) x -> a)
-eliminate here there (MkUnion i body)
-  | i == 0    = here  $ unsafeCoerce body
-  | otherwise = there $ MkUnion (i - 1) (unsafeCoerce body)
-
-instance Eq          (Union '[] a) where (==)       = vacuum
-instance Show        (Union '[] a) where show       = vacuum
-instance Functor     (Union '[])   where fmap     _ = vacuum
-instance Foldable    (Union '[])   where foldMap  _ = vacuum
-instance Traversable (Union '[])   where traverse _ = vacuum
-
-instance (Eq (f a), Eq (Union fs a)) => Eq (Union (f : fs) a) where
-  (==) = (==) `on` split
-
-instance (Show (f a), Show (Union fs a)) => Show (Union (f : fs) a) where
-  show = eliminate show show
-
-instance (Functor f, Functor (Union fs)) => Functor (Union (f : fs)) where
-  fmap f = eliminate (inj . fmap f) (raise . fmap f)
-
-instance (Foldable f, Foldable (Union fs)) => Foldable (Union (f : fs)) where
-  foldMap f = eliminate (foldMap f) (foldMap f)
-
-instance (Traversable f, Traversable (Union fs)) => Traversable (Union (f : fs)) where
-  traverse f = eliminate (fmap inj . traverse f) (fmap raise . traverse f)
-
-instance Pretty1 (Union '[]) where
-  pp1 = vacuum
-
-instance (Pretty1 f, Pretty1 (Union fs)) => Pretty1 (Union (f : fs)) where
-  pp1 = eliminate pp1 pp1

tools/lsp/squirrel/stack.yaml

@@ -39,6 +39,8 @@ extra-deps:
   - semantic-source-0.0.2.0@sha256:eac962ed1150d8647e703bc78369ecc4c1912db018e111f4ead8a62ae1a85542,2368
   - lingo-0.3.2.0@sha256:80b9ded65f2ddc0272a2872d9c3fc43c37934accae076d3e547dfc6c6b6e16d3,1899
   - semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909
+  - fastsum-0.1.1.1
+
 # - acme-missiles-0.3
 # - git: https://github.com/commercialhaskell/stack.git
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

tools/lsp/squirrel/stack.yaml.lock

@@ -32,6 +32,13 @@ packages:
       sha256: f3b6dd7ac1fa1b7a259334ff342405263da053af5c115bd86499227e2373d8ec
   original:
     hackage: semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909
+- completed:
+    hackage: fastsum-0.1.1.1@sha256:984ce99c8c153f31bffe03af6cc0599818878d62e9dae6ecb26b6623c92d6cec,2325
+    pantry-tree:
+      size: 431
+      sha256: 1c89d4034e6d06e15ff0ec421a95206c030ddc2d35b9eee7f0a02aa30c6051c1
+  original:
+    hackage: fastsum-0.1.1.1
 snapshots:
 - completed:
     size: 493124