From a45a4e94b305c8f37b76c50299cb4d0f9cc7eb1c Mon Sep 17 00:00:00 2001
From: Matei Adriel <rafaeladriel11@gmail.com>
Date: Sun, 18 Jun 2023 18:46:34 +0200
Subject: [PATCH] Added purpleflow

---
 purpleflow/.gitignore                         |  10 +
 purpleflow/packages.dhall                     | 105 ++++++++++
 purpleflow/packages/core/src/Data/AST.purs    | 147 ++++++++++++++
 purpleflow/packages/core/src/Data/CST.purs    |  77 +++++++
 .../packages/parsing-codec/src/Parser.purs    | 189 ++++++++++++++++++
 purpleflow/spago.dhall                        |  15 ++
 purpleflow/todo                               |   4 +
 7 files changed, 547 insertions(+)
 create mode 100644 purpleflow/.gitignore
 create mode 100644 purpleflow/packages.dhall
 create mode 100644 purpleflow/packages/core/src/Data/AST.purs
 create mode 100644 purpleflow/packages/core/src/Data/CST.purs
 create mode 100644 purpleflow/packages/parsing-codec/src/Parser.purs
 create mode 100644 purpleflow/spago.dhall
 create mode 100644 purpleflow/todo

diff --git a/purpleflow/.gitignore b/purpleflow/.gitignore
new file mode 100644
index 0000000..30efe19
--- /dev/null
+++ b/purpleflow/.gitignore
@@ -0,0 +1,10 @@
+/bower_components/
+/node_modules/
+/.pulp-cache/
+/output/
+/generated-docs/
+/.psc-package/
+/.psc*
+/.purs*
+/.psa*
+/.spago
diff --git a/purpleflow/packages.dhall b/purpleflow/packages.dhall
new file mode 100644
index 0000000..bfcd56d
--- /dev/null
+++ b/purpleflow/packages.dhall
@@ -0,0 +1,105 @@
+{-
+Welcome to your new Dhall package-set!
+
+Below are instructions for how to edit this file for most use
+cases, so that you don't need to know Dhall to use it.
+
+## Use Cases
+
+Most will want to do one or both of these options:
+1. Override/Patch a package's dependency
+2. Add a package not already in the default package set
+
+This file will continue to work whether you use one or both options.
+Instructions for each option are explained below.
+
+### Overriding/Patching a package
+
+Purpose:
+- Change a package's dependency to a newer/older release than the
+    default package set's release
+- Use your own modified version of some dependency that may
+    include new API, changed API, removed API by
+    using your custom git repo of the library rather than
+    the package set's repo
+
+Syntax:
+where `entityName` is one of the following:
+- dependencies
+- repo
+- version
+-------------------------------
+let upstream = --
+in  upstream
+  with packageName.entityName = "new value"
+-------------------------------
+
+Example:
+-------------------------------
+let upstream = --
+in  upstream
+  with halogen.version = "master"
+  with halogen.repo = "https://example.com/path/to/git/repo.git"
+
+  with halogen-vdom.version = "v4.0.0"
+  with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies
+-------------------------------
+
+### Additions
+
+Purpose:
+- Add packages that aren't already included in the default package set
+
+Syntax:
+where `<version>` is:
+- a tag (i.e. "v4.0.0")
+- a branch (i.e. "master")
+- commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977")
+-------------------------------
+let upstream = --
+in  upstream
+  with new-package-name =
+    { dependencies =
+       [ "dependency1"
+       , "dependency2"
+       ]
+    , repo =
+       "https://example.com/path/to/git/repo.git"
+    , version =
+        "<version>"
+    }
+-------------------------------
+
+Example:
+-------------------------------
+let upstream = --
+in  upstream
+  with benchotron =
+      { dependencies =
+          [ "arrays"
+          , "exists"
+          , "profunctor"
+          , "strings"
+          , "quickcheck"
+          , "lcg"
+          , "transformers"
+          , "foldable-traversable"
+          , "exceptions"
+          , "node-fs"
+          , "node-buffer"
+          , "node-readline"
+          , "datetime"
+          , "now"
+          ]
+      , repo =
+          "https://github.com/hdgarrood/purescript-benchotron.git"
+      , version =
+          "v7.0.0"
+      }
+-------------------------------
+-}
+let upstream =
+      https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220808/packages.dhall
+        sha256:60eee64b04ca0013fae3e02a69fc3b176105c6baa2f31865c67cd5f881a412fd
+
+in  upstream
diff --git a/purpleflow/packages/core/src/Data/AST.purs b/purpleflow/packages/core/src/Data/AST.purs
new file mode 100644
index 0000000..fd812be
--- /dev/null
+++ b/purpleflow/packages/core/src/Data/AST.purs
@@ -0,0 +1,147 @@
+module PF.Core.Data.Ast where
+
+import Prelude
+
+import Control.Monad.Error.Class (class MonadThrow, throwError)
+import Control.Monad.RWS (modify)
+import Control.Monad.State (class MonadState)
+import Data.HashMap (HashMap)
+import Data.HashMap as HashMap
+import Data.Maybe (Maybe(..), maybe)
+import PF.Core.Data.Cst as Cst
+import Safe.Coerce (coerce)
+
+newtype VarId = VarId Int
+newtype DBIndex = DBIndex Int
+newtype DBLevel = DBLevel Int
+newtype DBDepth = DBDepth Int
+
+type Expression = Expression_
+
+type VarInfo =
+  { id :: VarId
+  }
+
+data Expression_
+  = Lambda VarInfo Expression
+  | Var VarInfo DBIndex
+  | Let VarInfo Expression Expression
+  | Call Expression Expression
+  | Pi
+      { domain :: Expression
+      , codomain :: Expression
+      , var :: Maybe VarInfo
+      }
+  | Annotate
+      { value :: Expression
+      , type_ :: Expression
+      }
+  | Type
+
+type DesugarContext =
+  { scope ::
+      HashMap Cst.VarName
+        { id :: VarId
+        , level :: DBLevel
+        }
+  , depth :: DBDepth
+  }
+
+-- | For depth n 
+-- | 0 => n - 0
+-- | 1 => n - 1
+-- | ...
+-- | n - 1 => 1
+-- | n - 0=> 0
+levelToIndex :: DBDepth -> DBLevel -> DBIndex
+levelToIndex (DBDepth depth) (DBLevel level) =
+  DBIndex (depth - level)
+
+-- | Inverse of levelToIndex
+indexToLevel :: DBDepth -> DBIndex -> DBLevel
+indexToLevel (DBDepth depth) (DBIndex index) =
+  DBLevel (depth - index)
+
+increaseDepth :: DBDepth -> DBDepth
+increaseDepth (DBDepth a) = DBDepth (a + 1)
+
+depthToLevel :: DBDepth -> DBLevel
+depthToLevel = coerce
+
+type DesugarState = Int
+
+genId :: forall m. MonadState DesugarState m => m VarId
+genId = modify ((+) 1) # map coerce
+
+data DesugarError = VarNotFound Cst.VarName
+
+fromCST
+  :: forall m
+   . MonadState DesugarState m
+  => MonadThrow DesugarError m
+  => DesugarContext
+  -> Cst.Expression
+  -> m Expression
+fromCST context = case _ of
+  Cst.Type -> pure Type
+
+  Cst.Call f a -> ado
+    f <- fromCST context f
+    a <- fromCST context a
+    in Call f a
+
+  Cst.Annotate { value, type_ } -> ado
+    value <- fromCST context value
+    type_ <- fromCST context type_
+    in Annotate { value, type_ }
+
+  Cst.Var name -> case HashMap.lookup name context.scope of
+    Just { id, level } -> do
+      let index = levelToIndex context.depth level
+      pure $ Var { id } index
+    Nothing -> throwError (VarNotFound name)
+
+  Cst.Lambda arg body -> do
+    id <- genId
+    let extended = extendContext arg id context
+
+    body <- fromCST extended body
+
+    pure $ Lambda { id } body
+
+  Cst.Let var value body -> do
+    id <- genId
+    let extended = extendContext var id context
+
+    value <- fromCST context value
+    body <- fromCST extended body
+
+    pure $ Let { id } value body
+
+  Cst.Pi { var, domain, codomain } -> do
+    id <- genId
+
+    let
+      extended = var # maybe context
+        \var -> extendContext var id context
+
+    domain <- fromCST context domain
+    codomain <- fromCST extended codomain
+
+    pure $ Pi
+      { domain
+      , codomain
+      , var: var $> { id }
+      }
+
+  where
+  extendContext :: Cst.VarName -> VarId -> DesugarContext -> DesugarContext
+  extendContext var id context = do
+    let depth = increaseDepth context.depth
+    { depth: depth
+    , scope: HashMap.insert var
+        { id
+        , level: depthToLevel depth
+        }
+        context.scope
+    }
diff --git a/purpleflow/packages/core/src/Data/CST.purs b/purpleflow/packages/core/src/Data/CST.purs
new file mode 100644
index 0000000..c6c9812
--- /dev/null
+++ b/purpleflow/packages/core/src/Data/CST.purs
@@ -0,0 +1,77 @@
+module PF.Core.Data.Cst where
+
+import Prelude
+
+import Data.Array as Array
+import Data.CodePoint.Unicode (isAlpha)
+import Data.Hashable (class Hashable)
+import Data.Maybe (Maybe(..))
+import Data.Profunctor (dimap)
+import Data.Tuple.Nested ((/\))
+import PF.ParsingCodec.Parser as PC
+import Safe.Coerce (coerce)
+
+newtype VarName = VarName String
+
+data Expression
+  = Lambda VarName Expression
+  | Var VarName
+  | Let VarName Expression Expression
+  | Call Expression Expression
+  | Pi
+      { domain :: Expression
+      , codomain :: Expression
+      , var :: Maybe VarName
+      }
+  | Annotate
+      { value :: Expression
+      , type_ :: Expression
+      }
+  | Type
+
+-- Explicit syntax:
+{- 
+- foo
+- lam x -> ...
+- let a = b in c
+- f[a]
+- pi x : ty -> body
+- x :: y ???
+- *
+-}
+varName :: PC.ParsingCodec VarName VarName
+varName = dimap coerce coerce $ PC.takeWhile isAlpha
+
+codec_
+  :: PC.ParsingCodec Expression Expression
+  -> PC.ParsingCodec Expression Expression
+codec_ codec =
+  Array.fold
+    [ cType
+    , cLambda
+    ]
+  where
+  cType = PC.string "*" `PC.withConstantR` Type
+  cLambda = PC.dimapMaybe
+    translateL
+    translateR
+    ( PC.tuple
+        ( PC.surround
+            (PC.string "\\")
+            varName
+            (PC.string "->")
+        )
+        codec
+    )
+    where
+    translateR (var /\ expr) = Lambda var expr
+    translateL = case _ of
+      Lambda var expr -> Just (var /\ expr)
+      _ -> Nothing
+
+---------- Typeclass instances
+derive instance Eq VarName
+derive newtype instance Hashable VarName
+
+derive instance Eq Expression
+
diff --git a/purpleflow/packages/parsing-codec/src/Parser.purs b/purpleflow/packages/parsing-codec/src/Parser.purs
new file mode 100644
index 0000000..7601fbf
--- /dev/null
+++ b/purpleflow/packages/parsing-codec/src/Parser.purs
@@ -0,0 +1,189 @@
+module PF.ParsingCodec.Parser where
+
+import Prelude hiding ((*>), (<*))
+
+import Control.Alternative (guard, (<|>))
+import Control.Lazy (class Lazy)
+import Data.Maybe (Maybe(..))
+import Data.Profunctor (class Profunctor)
+import Data.String as String
+import Data.Tuple.Nested (type (/\), (/\))
+
+data ParsingCodec i o = ParsingCodec
+  (String -> Maybe (String /\ o))
+  (i -> Maybe String)
+
+string :: String -> ParsingCodec Unit String
+string target = ParsingCodec decode encode
+  where
+  encode _ = Just target
+  decode input = do
+    let
+      { before, after } = String.splitAt
+        (String.length target)
+        input
+
+    guard (target == before)
+    pure (after /\ target)
+
+takeWhile :: (String.CodePoint -> Boolean) -> ParsingCodec String String
+takeWhile predicate = ParsingCodec decode encode
+  where
+  encode = Just
+  decode input = do
+    let before = String.takeWhile predicate input
+    let after = String.drop (String.length before) input
+    pure (after /\ before)
+
+ws :: ParsingCodec Unit String
+ws = ParsingCodec decode encode
+  where
+  encode _ = Just " "
+  decode input = do
+    let
+      spaces = String.takeWhile
+        (_ == String.codePointFromChar ' ')
+        input
+
+    let after = String.drop (String.length spaces) input
+    pure (after /\ spaces)
+
+dimapMaybe
+  :: forall i o a b
+   . (a -> Maybe i)
+  -> (o -> b)
+  -> ParsingCodec i o
+  -> ParsingCodec a b
+dimapMaybe mapI mapO (ParsingCodec decode encode) = ParsingCodec
+  (\input -> decode input <#> map mapO)
+  (mapI >=> encode)
+
+wss :: ParsingCodec Unit String
+wss = ParsingCodec decode encode
+  where
+  encode _ = Just ""
+  decode input = do
+    let
+      spaces = String.takeWhile
+        (_ == String.codePointFromChar ' ')
+        input
+
+    guard (spaces /= "")
+
+    let after = String.drop (String.length spaces) input
+    pure (after /\ spaces)
+
+tuple
+  :: forall a b c d
+   . ParsingCodec a b
+  -> ParsingCodec c d
+  -> ParsingCodec (a /\ c) (b /\ d)
+tuple (ParsingCodec decodeL encodeL) (ParsingCodec decodeR encodeR) = ParsingCodec decode encode
+  where
+  encode (inputL /\ inputR) = ado
+    a <- encodeL inputL
+    b <- encodeR inputR
+    in (a <> b)
+
+  decode input = do
+    input /\ left <- decodeL input
+    remaining /\ right <- decodeR input
+    pure $ remaining /\ (left /\ right)
+
+ignoreLeft
+  :: forall a b c
+   . ParsingCodec Unit a
+  -> ParsingCodec b c
+  -> ParsingCodec b c
+ignoreLeft (ParsingCodec decodeL encodeL) (ParsingCodec decodeR encodeR) = ParsingCodec decode encode
+  where
+  encode input = ado
+    a <- encodeL unit
+    b <- encodeR input
+    in a <> b
+
+  decode input = do
+    input /\ _ <- decodeL input
+    remaining /\ right <- decodeR input
+    pure $ remaining /\ right
+
+ignoreRight
+  :: forall a b c
+   . ParsingCodec b c
+  -> ParsingCodec Unit a
+  -> ParsingCodec b c
+ignoreRight (ParsingCodec decodeL encodeL) (ParsingCodec decodeR encodeR) = ParsingCodec decode encode
+  where
+  encode input = ado
+    a <- encodeL input
+    b <- encodeR unit
+    in a <> b
+
+  decode input = do
+    input /\ left <- decodeL input
+    remaining /\ _ <- decodeR input
+    pure $ remaining /\ left
+
+infixl 4 ignoreRight as <*
+infixl 4 ignoreLeft as *>
+
+surround
+  :: forall l r i o
+   . ParsingCodec Unit l
+  -> ParsingCodec i o
+  -> ParsingCodec Unit r
+  -> ParsingCodec i o
+surround left middle right = left *> middle <* right
+
+withConstantL
+  :: forall o c
+   . Eq c
+  => c
+  -> ParsingCodec Unit o
+  -> ParsingCodec c c
+withConstantL inner (ParsingCodec decode encode) = ParsingCodec
+  decode'
+  encode'
+  where
+  decode' input = decode input <#> map (const inner)
+  encode' output = do
+    guard (output == inner)
+    encode unit
+
+withConstantR
+  :: forall o c
+   . Eq c
+  => ParsingCodec Unit o
+  -> c
+  -> ParsingCodec c c
+withConstantR = flip withConstantL
+
+infixl 4 withConstantL as <$
+infixl 4 withConstantR as $>
+
+decode :: forall i o. ParsingCodec i o -> (String -> Maybe (String /\ o))
+decode (ParsingCodec r _) = r
+
+encode :: forall i o. ParsingCodec i o -> (i -> Maybe String)
+encode (ParsingCodec _ l) = l
+
+---------- Typeclass instances
+instance Profunctor ParsingCodec where
+  dimap mapI mapO (ParsingCodec decode encode) = ParsingCodec
+    (\input -> decode input <#> map mapO)
+    (mapI >>> encode)
+
+instance Semigroup (ParsingCodec i o) where
+  append (ParsingCodec d e) (ParsingCodec d' e') =
+    ParsingCodec decode encode
+    where
+    decode i = d i <|> d' i
+    encode o = e o <|> e' o
+
+instance Monoid (ParsingCodec s r) where
+  mempty = ParsingCodec (const Nothing) (const Nothing)
+
+instance Lazy (ParsingCodec i o) where
+  defer mkCodec = ParsingCodec
+    (\i -> decode (mkCodec unit) i)
+    (\o -> encode (mkCodec unit) o)
diff --git a/purpleflow/spago.dhall b/purpleflow/spago.dhall
new file mode 100644
index 0000000..75820d3
--- /dev/null
+++ b/purpleflow/spago.dhall
@@ -0,0 +1,15 @@
+{ name = "purpleflow"
+, dependencies =
+  [ "codec"
+  , "console"
+  , "effect"
+  , "prelude"
+  , "run"
+  , "strings"
+  , "transformers"
+  , "unicode"
+  , "unordered-collections"
+  ]
+, packages = ./packages.dhall
+, sources = [ "packages/**/*.purs", "test/**/*.purs" ]
+}
diff --git a/purpleflow/todo b/purpleflow/todo
new file mode 100644
index 0000000..b38a3bd
--- /dev/null
+++ b/purpleflow/todo
@@ -0,0 +1,4 @@
+**Ast related stuff**
+- [ ] Define base ast
+- [ ] Write basic parser
+- [ ] Write logic for annoatating scopes and stuff