diff --git a/tools/lsp/squirrel/package.yaml b/tools/lsp/squirrel/package.yaml index 96084fd20..3b69622b8 100644 --- a/tools/lsp/squirrel/package.yaml +++ b/tools/lsp/squirrel/package.yaml @@ -9,6 +9,7 @@ dependencies: - template-haskell - text - tree-sitter + - fastsum default-extensions: - BangPatterns diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index 32079e019..f81023790 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/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" diff --git a/tools/lsp/squirrel/src/Pretty.hs b/tools/lsp/squirrel/src/Pretty.hs index ce787c28e..f0abd7719 100644 --- a/tools/lsp/squirrel/src/Pretty.hs +++ b/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 _ = "-" diff --git a/tools/lsp/squirrel/src/Tree.hs b/tools/lsp/squirrel/src/Tree.hs index 8d656a683..ae18e608b 100644 --- a/tools/lsp/squirrel/src/Tree.hs +++ b/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) - , Pretty1 (Union fs) + , Apply Functor 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) - , Traversable (Union fs) + :: ( UpdateOver m (Sum fs) (Tree fs a) + , 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 i fx = Tree $ Right (i, inj fx) +mk :: (Functor f, Element f fs) => info -> f (Tree fs info) -> Tree fs info +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 - before = error "Union.empty" - after = error "Union.empty" +instance Monad m => UpdateOver m (Sum '[]) a where + before = error "Sum.empty" + after = error "Sum.empty" -instance (UpdateOver m f a, UpdateOver m (Union fs) a) => UpdateOver m (Union (f : fs)) a where - before = eliminate before before - after = eliminate after after +instance (UpdateOver m f a, UpdateOver m (Sum fs) a) => UpdateOver m (Sum (f : fs)) a where + before = either before before . decompose + after = either after after . decompose diff --git a/tools/lsp/squirrel/src/Union.hs b/tools/lsp/squirrel/src/Union.hs deleted file mode 100644 index 691ec7cc6..000000000 --- a/tools/lsp/squirrel/src/Union.hs +++ /dev/null @@ -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 \ No newline at end of file diff --git a/tools/lsp/squirrel/stack.yaml b/tools/lsp/squirrel/stack.yaml index 68c34293a..495510ee4 100644 --- a/tools/lsp/squirrel/stack.yaml +++ b/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 diff --git a/tools/lsp/squirrel/stack.yaml.lock b/tools/lsp/squirrel/stack.yaml.lock index 24724eadc..df29dffa7 100644 --- a/tools/lsp/squirrel/stack.yaml.lock +++ b/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