balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Use Data.Sum instead of manual Union

Browse Source
This commit is contained in:
Kirill Andreev 2020-06-08 01:16:33 +04:00
parent 20de97c5c6
commit 9cf2e0cf97
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
7 changed files with 45 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
tools/lsp/squirrel/package.yaml
View File

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

8
tools/lsp/squirrel/src/AST/Parser.hs
View File

@ -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"

8
tools/lsp/squirrel/src/Pretty.hs
View File

@ -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 _ = "-"

43
tools/lsp/squirrel/src/Tree.hs
View File

@ -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

115
tools/lsp/squirrel/src/Union.hs
View File

@ -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

2
tools/lsp/squirrel/stack.yaml
View File

@ -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

7
tools/lsp/squirrel/stack.yaml.lock
View File

@ -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