Add documentation

This commit is contained in:
Kirill Andreev 2020-06-01 22:02:16 +04:00
parent d380e46737
commit 923a5bb9fe
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
17 changed files with 168 additions and 235 deletions

View File

@ -1,10 +1,10 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.33.0.
-- This file has been generated from package.yaml by hpack version 0.31.2.
--
-- see: https://github.com/sol/hpack
--
-- hash: fc91e2bbafd609769dba91a90992c659e68f017fa28f156cd261cd553083a47d
-- hash: 1c4275313cf3b683e190f5dc3ea95cd8cde978c09aa4f2269958de6128c73df3
name: squirrel
version: 0.0.0
@ -13,15 +13,18 @@ build-type: Simple
library
exposed-modules:
AST
AST.Errors
AST.Parser
AST.Scope
AST.Types
Error
HasComments
HasErrors
Lattice
Parser
ParseTree
Pretty
Range
Stubbed
TH
Tree
Union

View File

@ -318,8 +318,8 @@ data Scope = Scope { unScope :: Text }
instance HasComments Scope where
getComments = pure . ("(* " <>) . (<> " *)") . unScope
runScopeM :: ScopeM a -> a
runScopeM action = evalState action [Env []]
evalScopeM :: ScopeM a -> a
evalScopeM action = evalState action [Env []]
testUpdate :: Pascal ASTInfo -> ScopeM (Pascal Scope)
testUpdate = updateTree \_ -> do

View File

@ -1,9 +1,6 @@
{-
{- |
The AST and auxillary types along with their pretty-printers.
TODO: Untangle pretty-printing mess into combinators.
TODO: Store offending text verbatim in Wrong*.
-}
module AST.Types where
@ -24,29 +21,39 @@ import TH
import Debug.Trace
-- | The AST for Pascali... wait. It is, em, universal one.
--
-- TODO: Rename; add stuff if CamlLIGO/ReasonLIGO needs something.
--
type Pascal = Tree
[ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment
, MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding
, Declaration, Contract
]
data Contract it
= Contract [it]
deriving (Show) via PP (Contract it)
deriving stock (Functor, Foldable, Traversable)
data Declaration it
= ValueDecl it -- Binding
| TypeDecl it it -- Name Type
| Action it -- Expr
= ValueDecl it -- ^ Binding
| TypeDecl it it -- ^ Name Type
| Action it -- ^ Expr
| Include Text
deriving (Show) via PP (Declaration it)
deriving stock (Functor, Foldable, Traversable)
data Binding it
= Irrefutable it it -- (Pattern) (Expr)
| Function Bool it [it] it it -- (Name) [VarDecl] (Type) (Expr)
| Var it it it -- (Name) (Type) (Expr)
| Const it it it -- (Name) (Type) (Expr)
= Irrefutable it it -- ^ (Pattern) (Expr)
| Function Bool it [it] it it -- ^ (Name) [VarDecl] (Type) (Expr)
| Var it it it -- ^ (Name) (Type) (Expr)
| Const it it it -- ^ (Name) (Type) (Expr)
deriving (Show) via PP (Binding it)
deriving stock (Functor, Foldable, Traversable)
data VarDecl it
= Decl it it it -- (Mutable) (Name) (Type)
= Decl it it it -- ^ (Mutable) (Name) (Type)
deriving (Show) via PP (VarDecl it)
deriving stock (Functor, Foldable, Traversable)
@ -58,11 +65,11 @@ data Mutable it
data Type it
= TArrow it it -- (Type) (Type)
| TRecord [it] -- [TField]
| TVar it -- (Name)
| TSum [it] -- [Variant]
| TProduct [it] -- [Type]
= TArrow it it -- ^ (Type) (Type)
| TRecord [it] -- ^ [TField]
| TVar it -- ^ (Name)
| TSum [it] -- ^ [Variant]
| TProduct [it] -- ^ [Type]
| TApply it [it] -- (Name) [Type]
deriving (Show) via PP (Type it)
deriving stock (Functor, Foldable, Traversable)
@ -320,9 +327,3 @@ instance Pretty1 TField where
instance Pretty1 LHS where
pp1 = \case
LHS qn mi -> qn <> foldMap brackets mi
type Pascal = Tree
[ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment
, MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding
, Declaration, Contract
]

View File

@ -1,5 +1,8 @@
module Error where
module Error
( Error(..)
)
where
import Data.Text (Text)

View File

@ -1,13 +1,19 @@
module HasComments where
module HasComments
( HasComments(..)
, c
)
where
import qualified Data.Text as Text
import Pretty
-- | Ability to contain comments.
class HasComments c where
getComments :: c -> [Text.Text]
-- | Wrap some @Doc@ with a comment.
c :: HasComments i => i -> Doc -> Doc
c i d =
case getComments i of
@ -19,5 +25,6 @@ c i d =
then Text.init txt
else txt
-- | Narrator: /But there was none/.
instance HasComments () where
getComments () = []

View File

@ -1,6 +1,10 @@
module HasErrors where
module HasErrors
( HasErrors(..)
)
where
import Error
-- | Ability to contain `Error`s.
class HasErrors h where
errors :: h -> [Error]

View File

@ -1,6 +1,10 @@
module Lattice where
module Lattice
( Lattice(..)
)
where
-- | A range should have this property to be used for navigation.
class Lattice l where
(?>) :: l -> l -> Bool
(<?) :: l -> l -> Bool

View File

@ -1,7 +1,13 @@
{-# language StrictData #-}
module ParseTree where
module ParseTree
( ParseTree(..)
, ParseForest(..)
, toParseTree
, cutOut
)
where
import Data.IORef
import qualified Data.Text as Text
@ -35,13 +41,8 @@ import Paths_squirrel
import Range
import Pretty
-- import Debug.Trace
foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language
getNodeTypesPath :: IO FilePath
getNodeTypesPath = getDataFileName "../pascaligo/src/node-types.json"
-- | The tree tree-sitter produces.
data ParseTree = ParseTree
{ ptID :: Int -- ^ Unique number, for fast comparison.

View File

@ -1,18 +1,12 @@
{-
{- |
The thing that can untangle the mess that tree-sitter produced.
If there be errors, it /will/ be a mess.
In presence of serious errors, it /will/ be a mess, anyway.
The AST you are building must:
1) Have first field with type `ASTInfo` in each non-error constructor at each
type.
2) Have `Error`-only constructor to represent failure and implement `Stubbed`.
The AST you are building must be the @Tree@ in each point.
I recommend parametrising your `AST` with some `info` typevar to be
`ASTInfo` in the moment of parsing.
I also recomment, in your tree-sitter grammar, to add `field("foo", ...)`
I recommend, in your tree-sitter grammar, to add `field("foo", ...)`
to each sub-rule, that has `$.` in front of it - in a rule, that doesn't
start with `_` in its name.
@ -21,20 +15,21 @@
Only make rule start with `_` if it is a pure choice.
('block'
...
a: <a>
...
b: <b>
...)
> ('block'
> ...
> a: <a>
> ...
> b: <b>
> ...)
->
block = do
subtree "block" do
ctor Block
<*> inside "a" a
<*> inside "b" b
> block = do
> subtree "block" do
> ranged do
> pure Block
> <*> inside "a" a
> <*> inside "b" b
-}
module Parser
@ -220,6 +215,7 @@ die msg = throwError =<< makeError msg
die' msg rng = throwError =<< makeError' msg rng
complain msg rng = tell . pure =<< makeError' msg rng
-- | When tree-sitter found something it was unable to process.
unexpected :: ParseTree -> Error
unexpected ParseTree { ptSource, ptRange } =
Expected "not that" ptSource ptRange
@ -249,9 +245,11 @@ subtree msg parser = do
(<|>) :: Parser a -> Parser a -> Parser a
Parser l <|> Parser r = Parser (l `catchError` const r)
-- | Custom @foldl1 (<|>)@.
select :: [Parser a] -> Parser a
select = foldl1 (<|>)
-- | Custom @optionMaybe@.
optional :: Parser a -> Parser (Maybe a)
optional p = fmap Just p <|> return Nothing
@ -306,7 +304,7 @@ debugParser parser fin = do
putStrLn "Errors:"
for_ errs (print . nest 2 . pp)
-- | Consume next tree if it has give name. Or die.
-- | Consume next tree if it has the given name. Or die.
token :: Text -> Parser Text
token node = do
tree@ParseTree {ptName, ptRange, ptSource} <- takeNext node
@ -320,7 +318,7 @@ anything = do
tree <- takeNext "anything"
return $ ptSource tree
-- | Get range of current tree or forest before the parser was run.
-- | Get range of the current tree (or forest) before the parser was run.
range :: Parser a -> Parser (a, Range)
range parser =
get >>= \case
@ -381,9 +379,6 @@ notFollowedBy parser = do
unless good do
die "notFollowedBy"
stub :: Stubbed a => Error -> a
stub = stubbing
-- | Universal accessor.
--
-- Usage:
@ -428,6 +423,7 @@ instance HasRange ASTInfo where
getInfo :: Parser ASTInfo
getInfo = ASTInfo <$> currentRange <*> grabComments
-- | Take the accumulated comments, clean the accumulator.
grabComments :: Parser [Text]
grabComments = do
(st, comms) <- get

View File

@ -3,7 +3,19 @@
-}
module Pretty
( module Pretty
( ppToText
, PP(..)
, Pretty(..)
, Pretty1(..)
, tuple
, list
, indent
, above
, train
, block
, sepByDot
, mb
, sparseBlock
, module Text.PrettyPrint
)
where
@ -13,6 +25,7 @@ import Data.Text (Text, pack)
import Text.PrettyPrint hiding ((<>))
-- | Pretty-print to `Text`. Through `String`. Yep.
ppToText :: Pretty a => a -> Text
ppToText = pack . show . pp
@ -26,6 +39,7 @@ instance Pretty a => Show (PP a) where
class Pretty p where
pp :: p -> Doc
-- | Pretty-printable `Functors`.
class Pretty1 p where
pp1 :: p Doc -> Doc
@ -40,28 +54,40 @@ instance Pretty Text where
instance Pretty Doc where
pp = id
-- | Decorate list of stuff as a tuple.
tuple :: Pretty p => [p] -> Doc
tuple = parens . train ","
-- | Decorate list of stuff as a list.
list :: Pretty p => [p] -> Doc
list = brackets . train ";"
infixr 2 `indent`
-- | First argument is a header to an indented second one.
indent :: Doc -> Doc -> Doc
indent a b = hang a 2 b
infixr 1 `above`
-- | Horisontal composition.
above :: Doc -> Doc -> Doc
above a b = hang a 0 b
-- | Pretty print as a sequence with given separator.
train :: Pretty p => Doc -> [p] -> Doc
train sep = fsep . punctuate sep . map pp
-- | Pretty print as a vertical block.
block :: Pretty p => [p] -> Doc
block = vcat . map pp
-- | For pretty-printing qualified names.
sepByDot :: Pretty p => [p] -> Doc
sepByDot = cat . map (("." <>) . pp)
-- | For pretty-printing `Maybe`s.
mb :: Pretty a => (Doc -> Doc) -> Maybe a -> Doc
mb f = maybe empty (f . pp)
-- | Pretty print as a vertical with elements separated by newline.
sparseBlock :: Pretty a => [a] -> Doc
sparseBlock = vcat . punctuate "\n" . map (($$ empty) . pp)

View File

@ -1,11 +1,16 @@
module Range where
module Range
( Range(..)
, HasRange(..)
, diffRange
)
where
import Control.Lens
import Pretty
-- | A continuous location in text.
-- | A continious location in text.
data Range = Range
{ rStart :: (Int, Int, Int) -- ^ [Start: line, col, byte-offset...
, rFinish :: (Int, Int, Int) -- ^ ... End: line, col, byte-offset).
@ -21,5 +26,6 @@ instance Pretty Range where
brackets do
int ll <> ":" <> int lc <> "-" <> int rl <> ":" <> int rc
-- | Ability to get range out of something.
class HasRange a where
getRange :: a -> Range

View File

@ -1,5 +1,8 @@
module Stubbed where
module Stubbed
( Stubbed (..)
)
where
import Control.Lens
@ -9,20 +12,22 @@ import Error
-- | For types that have a default replacer with an `Error`.
class Stubbed a where
stubbing :: Error -> a
stub :: Error -> a
instance Stubbed Text where
stubbing = pack . show
stub = pack . show
-- | This is bad, but I had to.
--
-- TODO: Find a way to remove this instance.
-- I probably need a wrapper around '[]'.
--
-- Or I need a @fields@ parser combinator.
--
instance Stubbed [a] where
stubbing = const []
stub = const []
-- | `Nothing` would be bad default replacer.
-- | Is `Just` `.` @stubbing@.
instance Stubbed a => Stubbed (Maybe a) where
stubbing = Just . stubbing
stub = Just . stub

View File

@ -5,9 +5,6 @@ import Control.Applicative
import Language.Haskell.TH.Syntax (Q)
instance Semigroup a => Semigroup (Q a) where
(<>) = liftA2 (<>)
instance Monoid a => Monoid (Q a) where
mempty = pure mempty
instance Semigroup a => Semigroup (Q a) where (<>) = liftA2 (<>)
instance Monoid a => Monoid (Q a) where mempty = pure mempty

View File

@ -1,5 +1,12 @@
module Tree where
module Tree
( Tree
, spineTo
, updateTree
, mk
, infoOf
)
where
import Data.Fix
import Data.Functor.Compose
@ -13,7 +20,12 @@ import Pretty
import Error
import Stubbed
-- | Tree is a fixpoint of `Union` @layers@, each equipped with an @info@.
-- | A tree, where each layer is one of @layers@ `Functor`s.
--
-- Is equipped with @info@.
--
-- Can contain `Error` instead of all the above.
--
newtype Tree layers info = Tree
{ unTree :: Fix (Either Error `Compose` (,) info `Compose` Union layers)
}
@ -48,7 +60,7 @@ instance {-# OVERLAPS #-}
aux (Compose (Left err)) = pp err
aux (Compose (Right (Compose (info, fTree)))) = c info $ pp fTree
-- Return all subtrees that cover the range, ascending in side.
-- | Return all subtrees that cover the range, ascending in size.
spineTo
:: ( Lattice info
, Foldable (Union fs)
@ -66,7 +78,10 @@ spineTo info = reverse . go . unTree
go _ = []
-- | Update the tree in the monad that exports its methods.
-- | Update the tree over some monad that exports its methods.
--
-- For each tree piece, will call `before` and `after` callbacks.
--
updateTree
:: ( UpdateOver m (Union fs) (Tree fs a)
, Traversable (Union fs)
@ -89,6 +104,7 @@ updateTree act = fmap Tree . go . unTree
mk :: (Functor f, Member f fs) => info -> f (Tree fs info) -> Tree fs info
mk i fx = Tree $ Fix $ Compose $ Right $ Compose (i, inj $ fmap unTree fx)
-- | Get info from the tree.
infoOf :: Tree fs info -> Maybe info
infoOf (Tree (Fix (Compose it))) =
either
@ -96,7 +112,7 @@ infoOf (Tree (Fix (Compose it))) =
(Just . fst . getCompose) it
instance Stubbed (Tree fs info) where
stubbing = Tree . Fix . Compose . Left
stub = Tree . Fix . Compose . Left
instance Foldable (Union fs) => HasErrors (Tree fs info) where
errors = go . unTree

View File

@ -8,17 +8,15 @@ module Union
import Update
import Pretty
{-
The "one of" datatype.
Each `Union fs a` is a `f a`, where `f` is one of `fs`.
-}
-- | The "one of" datatype.
--
-- Each @Union fs a@ is a @f a@, where @f@ is one of @fs@`.
data Union fs x where
Here :: f x -> Union (f : fs) x
There :: Union fs x -> Union (f : fs) x
instance Eq (Union '[] a) where (==) = error "Union.empty"
instance Show (Union '[] a) where show = error "Union.empty"
instance Functor (Union '[]) where fmap = error "Union.empty"
instance Foldable (Union '[]) where foldMap = error "Union.empty"
instance Traversable (Union '[]) where traverse = error "Union.empty"
@ -36,9 +34,7 @@ deriving stock instance (Functor f, Functor (Union fs)) => Functor (
deriving stock instance (Foldable f, Foldable (Union fs)) => Foldable (Union (f : fs))
deriving stock instance (Traversable f, Traversable (Union fs)) => Traversable (Union (f : fs))
{-
A case over `Union`.
-}
-- | A case over `Union`.
eliminate
:: (f x -> a)
-> (Union fs x -> a)
@ -47,12 +43,10 @@ eliminate here there = \case
Here fx -> here fx
There rest -> there rest
{-
The `f` functior is in the `fs` list.
-}
-- | The `f` functior is in the `fs` list.
class Member f fs where
inj :: f x -> Union fs x -- embed f into some Union
proj :: Union fs x -> Maybe (f x) -- check if a Union is actually f
inj :: f x -> Union fs x -- ^ embed @f@ into some `Union`
proj :: Union fs x -> Maybe (f x) -- ^ check if a `Union` is actually @f@
instance {-# OVERLAPS #-} Member f (f : fs) where
inj = Here

View File

@ -1,16 +1,17 @@
module Update where
module Update
( HasMethods(..)
, UpdateOver(..)
, skip
)
where
{-
Abstraction over monad capabilities.
-}
-- | Abstraction over monad capabilities.
class Monad m => HasMethods m where
data Methods m :: *
method :: Methods m
{-
Given some AST structure, do some stuff before & after it is traversed.
-}
-- | Update callbacks for a @f a@ while working inside monad @m@.
class HasMethods m => UpdateOver m f a where
before :: f a -> m ()
after :: f a -> m ()
@ -18,5 +19,6 @@ class HasMethods m => UpdateOver m f a where
before _ = skip
after _ = skip
-- | Do nothing.
skip :: Monad m => m ()
skip = return ()

View File

@ -1,132 +0,0 @@
('contract' [1:1 - 4:1]
('declaration' [1:1 - 3:25]
('fun_decl' [1:1 - 3:25]
('open_fun_decl' [1:1 - 3:25]
('function' [1:1 - 1:9])
('fun_name' [1:10 - 1:14]
('ident' [1:10 - 1:14] ('Name' [1:10 - 1:14])))
('parameters' [1:15 - 1:35]
('(' [1:15 - 1:16])
('param_decl' [1:16 - 1:34]
('access' [1:16 - 1:21] ('const' [1:16 - 1:21]))
('var' [1:22 - 1:23]
('ident' [1:22 - 1:23] ('Name' [1:22 - 1:23])))
(':' [1:24 - 1:25])
('param_type' [1:26 - 1:34]
('fun_type' [1:26 - 1:34]
('cartesian' [1:26 - 1:34]
('core_type' [1:26 - 1:34]
('type_name' [1:26 - 1:34]
('ident' [1:26 - 1:34] ('Name' [1:26 - 1:34]))))))))
(')' [1:34 - 1:35]))
(':' [1:36 - 1:37])
('type_expr' [1:38 - 1:45]
('fun_type' [1:38 - 1:45]
('cartesian' [1:38 - 1:45]
('core_type' [1:38 - 1:45]
('type_name' [1:38 - 1:45]
('ident' [1:38 - 1:45] ('Name' [1:38 - 1:45])))))))
('is' [1:46 - 1:48])
('block' [1:49 - 3:2]
('block' [1:49 - 1:54])
('{' [1:55 - 1:56])
('statement' [2:3 - 2:57]
('open_data_decl' [2:3 - 2:57]
('open_const_decl' [2:3 - 2:57]
('const' [2:3 - 2:8])
('var' [2:9 - 2:10] ('ident' [2:9 - 2:10] ('Name' [2:9 - 2:10])))
(':' [2:11 - 2:12])
('type_expr' [2:13 - 2:28]
('fun_type' [2:13 - 2:28]
('cartesian' [2:13 - 2:28]
('core_type' [2:13 - 2:28]
('type_name' [2:13 - 2:21]
('ident' [2:13 - 2:21] ('Name' [2:13 - 2:21])))
('type_tuple' [2:22 - 2:28]
('(' [2:22 - 2:23])
('type_expr' [2:23 - 2:27]
('fun_type' [2:23 - 2:27]
('cartesian' [2:23 - 2:27]
('core_type' [2:23 - 2:27]
('type_name' [2:23 - 2:27]
('ident' [2:23 - 2:27]
('Name' [2:23 - 2:27])))))))
(')' [2:27 - 2:28]))))))
('=' [2:29 - 2:30])
('expr' [2:31 - 2:57]
('disj_expr' [2:31 - 2:57]
('conj_expr' [2:31 - 2:57]
('set_membership' [2:31 - 2:57]
('comp_expr' [2:31 - 2:57]
('cat_expr' [2:31 - 2:57]
('cons_expr' [2:31 - 2:57]
('add_expr' [2:31 - 2:57]
('mult_expr' [2:31 - 2:57]
('unary_expr' [2:31 - 2:57]
('core_expr' [2:31 - 2:57]
('fun_call_or_par_or_projection' [2:31 - 2:57]
('fun_call' [2:31 - 2:57]
('module_field' [2:31 - 2:53]
('module_name' [2:31 - 2:36]
('Name_Capital' [2:31 - 2:36]))
('.' [2:36 - 2:37])
('module_fun' [2:37 - 2:53]
('field_name' [2:37 - 2:53]
('ident' [2:37 - 2:53]
('Name' [2:37 - 2:53])))))
('arguments' [2:54 - 2:57]
('(' [2:54 - 2:55])
('expr' [2:55 - 2:56]
('disj_expr' [2:55 - 2:56]
('conj_expr' [2:55 - 2:56]
('set_membership' [2:55 - 2:56]
('comp_expr' [2:55 - 2:56]
('cat_expr' [2:55 - 2:56]
('cons_expr' [2:55 - 2:56]
('add_expr' [2:55 - 2:56]
('mult_expr' [2:55 - 2:56]
('unary_expr' [2:55 - 2:56]
('core_expr' [2:55 - 2:56]
('ident' [2:55 - 2:56]
('Name' [2:55 - 2:56])))))))))))))
(')' [2:56 - 2:57]))))))))))))))))))
(';' [2:57 - 2:58])
('}' [3:1 - 3:2]))
('with' [3:3 - 3:7])
('expr' [3:8 - 3:25]
('disj_expr' [3:8 - 3:25]
('conj_expr' [3:8 - 3:25]
('set_membership' [3:8 - 3:25]
('comp_expr' [3:8 - 3:25]
('cat_expr' [3:8 - 3:25]
('cons_expr' [3:8 - 3:25]
('add_expr' [3:8 - 3:25]
('mult_expr' [3:8 - 3:25]
('unary_expr' [3:8 - 3:25]
('core_expr' [3:8 - 3:25]
('fun_call_or_par_or_projection' [3:8 - 3:25]
('fun_call' [3:8 - 3:25]
('module_field' [3:8 - 3:21]
('module_name' [3:8 - 3:13]
('Name_Capital' [3:8 - 3:13]))
('.' [3:13 - 3:14])
('module_fun' [3:14 - 3:21]
('field_name' [3:14 - 3:21]
('ident' [3:14 - 3:21]
('Name' [3:14 - 3:21])))))
('arguments' [3:22 - 3:25]
('(' [3:22 - 3:23])
('expr' [3:23 - 3:24]
('disj_expr' [3:23 - 3:24]
('conj_expr' [3:23 - 3:24]
('set_membership' [3:23 - 3:24]
('comp_expr' [3:23 - 3:24]
('cat_expr' [3:23 - 3:24]
('cons_expr' [3:23 - 3:24]
('add_expr' [3:23 - 3:24]
('mult_expr' [3:23 - 3:24]
('unary_expr' [3:23 - 3:24]
('core_expr' [3:23 - 3:24]
('ident' [3:23 - 3:24]
('Name' [3:23 - 3:24])))))))))))))
(')' [3:24 - 3:25])))))))))))))))))))