From e2976f2c06e4485639b3ec6f954b169c9c72543e Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm+symantic-parser@sourcephile.fr>
Date: Thu, 3 Sep 2020 10:10:11 +0200
Subject: [PATCH 1/1] init

---
 .gitignore                                   |   1 +
 src/Symantic/Base/Univariant.hs              |  37 +++
 src/Symantic/Parser.hs                       |   6 +
 src/Symantic/Parser/Grammar.hs               |   6 +
 src/Symantic/Parser/Grammar/Combinators.hs   |  89 +++++++
 src/Symantic/Parser/Grammar/Optimizations.hs | 231 +++++++++++++++++++
 src/Symantic/Parser/Staging.hs               | 139 +++++++++++
 stack.yaml                                   |   1 +
 stack.yaml.lock                              |  12 +
 symantic-parser.cabal                        |  62 +++++
 10 files changed, 584 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 src/Symantic/Base/Univariant.hs
 create mode 100644 src/Symantic/Parser.hs
 create mode 100644 src/Symantic/Parser/Grammar.hs
 create mode 100644 src/Symantic/Parser/Grammar/Combinators.hs
 create mode 100644 src/Symantic/Parser/Grammar/Optimizations.hs
 create mode 100644 src/Symantic/Parser/Staging.hs
 create mode 100644 stack.yaml
 create mode 100644 stack.yaml.lock
 create mode 100644 symantic-parser.cabal

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..3a5b475
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+.stack-work/
diff --git a/src/Symantic/Base/Univariant.hs b/src/Symantic/Base/Univariant.hs
new file mode 100644
index 0000000..656585a
--- /dev/null
+++ b/src/Symantic/Base/Univariant.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE DefaultSignatures #-}
+module Symantic.Base.Univariant where
+
+import Data.Function ((.))
+
+-- * Type family 'Unlift'
+type family Unlift (repr :: * -> *) :: * -> *
+-- * Class 'Unliftable'
+class Unliftable repr where
+  unlift :: repr a -> Unlift repr a
+-- * Class 'Liftable'
+class Liftable repr where
+  lift :: Unlift repr a -> repr a
+  lift1 :: (Unlift repr a -> Unlift repr b) ->
+           repr a -> repr b
+  lift2 :: (Unlift repr a -> Unlift repr b -> Unlift repr c) ->
+           repr a -> repr b -> repr c
+  lift3 :: (Unlift repr a -> Unlift repr b -> Unlift repr c -> Unlift repr d) ->
+           repr a -> repr b -> repr c -> repr d
+  default lift1 ::
+           Unliftable repr =>
+           (Unlift repr a -> Unlift repr b) ->
+           repr a -> repr b
+  default lift2 ::
+           Unliftable repr =>
+           (Unlift repr a -> Unlift repr b -> Unlift repr c) ->
+           repr a -> repr b -> repr c
+  default lift3 ::
+           Unliftable repr =>
+           (Unlift repr a -> Unlift repr b -> Unlift repr c -> Unlift repr d) ->
+           repr a -> repr b -> repr c -> repr d
+  lift1 f = lift . f . unlift
+  lift2 f a b = lift (f (unlift a) (unlift b))
+  lift3 f a b c = lift (f (unlift a) (unlift b) (unlift c))
+  {-# INLINE lift1 #-}
+  {-# INLINE lift2 #-}
+  {-# INLINE lift3 #-}
diff --git a/src/Symantic/Parser.hs b/src/Symantic/Parser.hs
new file mode 100644
index 0000000..4fe05bf
--- /dev/null
+++ b/src/Symantic/Parser.hs
@@ -0,0 +1,6 @@
+module Symantic.Parser
+ ( module Symantic.Parser.Grammar
+ , module Symantic.Parser.Staging
+ ) where
+import Symantic.Parser.Grammar
+import Symantic.Parser.Staging
diff --git a/src/Symantic/Parser/Grammar.hs b/src/Symantic/Parser/Grammar.hs
new file mode 100644
index 0000000..10a94fc
--- /dev/null
+++ b/src/Symantic/Parser/Grammar.hs
@@ -0,0 +1,6 @@
+module Symantic.Parser.Grammar
+ ( module Symantic.Parser.Grammar.Combinators
+ , module Symantic.Parser.Grammar.Optimizations
+ ) where
+import Symantic.Parser.Grammar.Combinators
+import Symantic.Parser.Grammar.Optimizations
diff --git a/src/Symantic/Parser/Grammar/Combinators.hs b/src/Symantic/Parser/Grammar/Combinators.hs
new file mode 100644
index 0000000..ffe2753
--- /dev/null
+++ b/src/Symantic/Parser/Grammar/Combinators.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Symantic.Parser.Grammar.Combinators where
+import Data.Function ((.))
+import Data.Bool (Bool)
+import Data.Char (Char)
+import Data.Kind (Type)
+import Data.Either (Either)
+
+import Symantic.Base.Univariant
+
+-- * Class 'Applicable'
+class Applicable repr where
+  type Pure repr :: Type -> Type
+  pure :: Pure repr a -> repr a
+  (<$>) :: Pure repr (a -> b) -> repr a -> repr b
+  (<*>) :: repr (a -> b) -> repr a -> repr b
+  (<*) :: repr a -> repr b -> repr a
+  (*>) :: repr a -> repr b -> repr b
+  default pure ::
+    Liftable repr => Applicable (Unlift repr) =>
+    Pure (Unlift repr) ~ Pure repr =>
+    Pure repr a -> repr a
+  default (<$>) ::
+    Liftable repr => Applicable (Unlift repr) =>
+    Pure (Unlift repr) ~ Pure repr =>
+    Pure repr (a -> b) -> repr a -> repr b
+  default (<*>) ::
+    Liftable repr => Applicable (Unlift repr) =>
+    repr (a -> b) -> repr a -> repr b
+  default (<*) ::
+    Liftable repr => Applicable (Unlift repr) =>
+    repr a -> repr b -> repr a
+  default (*>) ::
+    Liftable repr => Applicable (Unlift repr) =>
+    repr a -> repr b -> repr b
+  pure = lift . pure
+  (<$>) f = lift1 (f <$>)
+  (<*>) = lift2 (<*>)
+  (<*) = lift2 (<*)
+  (*>) = lift2 (*>)
+infixl 4 <$>, <*>, <*, *>
+
+-- * Class 'Alternable'
+class Alternable repr where
+  (<|>) :: repr a -> repr a -> repr a
+  empty :: repr a
+  try :: repr a -> repr a
+  default (<|>) ::
+    Liftable repr => Alternable (Unlift repr) =>
+    repr a -> repr a -> repr a
+  default empty ::
+    Liftable repr => Alternable (Unlift repr) =>
+    repr a
+  default try ::
+    Liftable repr => Alternable (Unlift repr) =>
+    repr a -> repr a
+  (<|>) = lift2 (<|>)
+  empty = lift empty
+  try = lift1 try
+infixl 3 <|>
+
+-- * Class 'Selectable'
+class Selectable repr where
+  branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
+  default branch ::
+    Liftable repr => Selectable (Unlift repr) =>
+    repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
+  branch  = lift3 branch
+
+-- * Class 'Charable'
+class Charable repr where
+  satisfy :: Pure repr (Char -> Bool) -> repr Char
+  default satisfy ::
+    Pure (Unlift repr) ~ Pure repr =>
+    Liftable repr => Charable (Unlift repr) =>
+    Pure repr (Char -> Bool) -> repr Char
+  satisfy = lift . satisfy
+
+-- * Class 'Lookable'
+class Lookable repr where
+  look :: repr a -> repr a
+  negLook :: repr a -> repr ()
+  default look    :: Liftable repr => Lookable (Unlift repr) => repr a -> repr a
+  default negLook :: Liftable repr => Lookable (Unlift repr) => repr a -> repr ()
+  look    = lift1 look
+  negLook = lift1 negLook
+
diff --git a/src/Symantic/Parser/Grammar/Optimizations.hs b/src/Symantic/Parser/Grammar/Optimizations.hs
new file mode 100644
index 0000000..53b4a10
--- /dev/null
+++ b/src/Symantic/Parser/Grammar/Optimizations.hs
@@ -0,0 +1,231 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+module Symantic.Parser.Grammar.Optimizations where
+
+import Data.Bool (Bool)
+import Data.Char (Char)
+import Data.Either (Either(..), either)
+import Prelude (undefined)
+import qualified Data.Function as Function
+import Data.Eq (Eq(..))
+import Data.Typeable
+import Data.Maybe (Maybe(..))
+
+import Symantic.Base.Univariant
+import Symantic.Parser.Grammar.Combinators
+import Symantic.Parser.Staging hiding (Runtimeable(..), OptRuntime(..))
+import qualified Symantic.Parser.Staging as S
+import qualified Language.Haskell.TH.Syntax as TH
+
+-- * Type 'OptGram'
+data OptGram repr a where
+  Pure    :: Pure repr a -> OptGram repr a
+  Satisfy :: Pure repr (Char -> Bool) -> OptGram repr Char
+  Try     :: OptGram repr a -> OptGram repr a
+  Look    :: OptGram repr a -> OptGram repr a
+  NegLook :: OptGram repr a -> OptGram repr ()
+  (:<*>)  :: OptGram repr (a -> b) -> OptGram repr a -> OptGram repr b
+  (:<*)   :: OptGram repr a -> OptGram repr b -> OptGram repr a
+  (:*>)   :: OptGram repr a -> OptGram repr b -> OptGram repr b
+  (:<|>)  :: OptGram repr a -> OptGram repr a -> OptGram repr a
+  Empty   :: OptGram repr a
+  Branch  :: OptGram repr (Either a b) -> OptGram repr (a -> c) -> OptGram repr (b -> c) -> OptGram repr c
+
+pattern (:<$>) :: Pure repr (a -> b) -> OptGram repr a -> OptGram repr b
+pattern (:$>) :: OptGram repr a -> Pure repr b -> OptGram repr b
+pattern (:<$) :: Pure repr a -> OptGram repr b -> OptGram repr a
+pattern x :<$> p = Pure x :<*> p
+pattern p  :$> x = p :*> Pure x
+pattern x :<$  p = Pure x :<* p
+
+infixl 3 :<|>
+infixl 4 :<*>, :<*, :*>
+infixl 4 :<$>, :<$, :$>
+
+instance Applicable (OptGram repr) where
+  type Pure (OptGram repr) = Pure repr
+  pure = Pure
+  (<$>) f = (Pure f :<*>)
+  (<*>) = (:<*>)
+  (<*) = (:<*)
+  (*>) = (:*>)
+instance Alternable (OptGram repr) where
+  (<|>) = (:<|>)
+  empty = Empty
+  try = Try
+instance Selectable (OptGram repr) where
+  branch = Branch
+instance Charable (OptGram repr) where
+  satisfy = Satisfy
+instance Lookable (OptGram repr) where
+  look = Look
+  negLook = NegLook
+type instance Unlift (OptGram repr) = repr
+instance
+ ( Applicable repr
+ , Alternable repr
+ , Selectable repr
+ , Charable repr
+ , Lookable repr
+ ) => Unliftable (OptGram repr) where
+  unlift = \case
+    Pure a    -> pure a
+    Satisfy p -> satisfy p
+    Try x     -> try (unlift x)
+    Look x    -> look (unlift x)
+    NegLook x -> negLook (unlift x)
+    x :<*> y  -> unlift x <*> unlift y
+    x :<*  y  -> unlift x <*  unlift y
+    x  :*> y  -> unlift x  *> unlift y
+    x :<|> y  -> unlift x <|> unlift y
+    Empty     -> empty
+    Branch lr l r -> branch (unlift lr) (unlift l) (unlift r)
+
+optGram ::
+ Pure repr ~ S.OptRuntime Runtime =>
+ OptGram repr a -> OptGram repr a
+optGram = \case
+  -- Applicable Right Absorption Law
+  Empty :<*> _ -> Empty
+  Empty  :*> _ -> Empty
+  Empty :<*  _ -> Empty
+  -- Applicable Failure Weakening Law
+  u :<*> Empty -> optGram (u :*> Empty)
+  u :<*  Empty -> optGram (u :*> Empty)
+  -- Branch Absorption Law
+  Branch Empty _ _ -> empty
+  -- Branch Weakening Law
+  Branch b Empty Empty -> optGram (b :*> Empty)
+
+  -- Applicable Identity Law
+  S.Id :<$> x -> x
+  -- Flip const optimisation
+  S.Flip S.:@ S.Const :<$> u -> optGram (u :*> Pure S.Id)
+  -- Homomorphism Law
+  f :<$> Pure x -> Pure (f S.:@ x)
+  -- Functor Composition Law
+  -- (a shortcut that could also have been be caught
+  -- by the Composition Law and Homomorphism law)
+  f :<$> (g :<$> p) -> optGram ((S.:.) S.:@ f S.:@ g :<$> p)
+  -- Composition Law
+  u :<*> (v :<*> w) -> optGram (optGram (optGram ((S.:.) :<$> u) :<*> v) :<*> w)
+  -- Definition of *>
+  S.Flip S.:@ S.Const :<$> p :<*> q -> p :*> q
+  -- Definition of <*
+  S.Const :<$> p :<*> q -> p :<* q
+  -- Reassociation Law 1
+  (u :*> v) :<*> w -> optGram (u :*> (optGram (v :<*> w)))
+  -- Interchange Law
+  u :<*> Pure x -> optGram (S.Flip S.:@ (S.:$) S.:@ x :<$> u)
+  -- Right Absorption Law
+  (_ :<$> p) :*> q -> p :*> q
+  -- Left Absorption Law
+  p :<* (_ :<$> q) -> p :<* q
+  -- Reassociation Law 2
+  u :<*> (v :<* w) -> optGram (optGram (u :<*> v) :<* w)
+  -- Reassociation Law 3
+  u :<*> (v :$> x) -> optGram (optGram (u :<*> Pure x) :<* v)
+
+  -- Left Catch Law
+  p@Pure{} :<|> _ -> p
+  -- Left Neutral Law
+  Empty :<|> u -> u
+  -- Right Neutral Law
+  u :<|> Empty -> u
+  -- Associativity Law
+  (u :<|> v) :<|> w -> u :<|> optGram (v :<|> w)
+
+  -- Identity law
+  Pure _ :*> u -> u
+  -- Identity law
+  (u :$> _) :*> v -> u :*> v
+  -- Associativity Law
+  u :*> (v :*> w) -> optGram (optGram (u :*> v) :*> w)
+  -- Identity law
+  u :<* Pure _ -> u
+  -- Identity law
+  u :<* (v :$> _) -> optGram (u :<* v)
+  -- Commutativity Law
+  x :<$ u -> optGram (u :$> x)
+  -- Associativity Law
+  (u :<* v) :<* w -> optGram (u :<* optGram (v :<* w))
+
+  -- Pure lookahead
+  Look p@Pure{} -> p
+  -- Dead lookahead
+  Look p@Empty -> p
+  -- Pure negative-lookahead
+  NegLook Pure{} -> Empty
+
+  -- Dead negative-lookahead
+  NegLook Empty -> Pure S.unit
+  -- Double Negation Law
+  NegLook (NegLook p) -> optGram (Look (Try p) :*> Pure S.unit)
+  -- Zero Consumption Law
+  NegLook (Try p) -> optGram (NegLook p)
+  -- Idempotence Law
+  Look (Look p) -> Look p
+  -- Right Identity Law
+  NegLook (Look p) -> optGram (NegLook p)
+
+  -- Left Identity Law
+  Look (NegLook p) -> NegLook p
+  -- Transparency Law
+  NegLook (Try p :<|> q) -> optGram (optGram (NegLook p) :*> optGram (NegLook q))
+  -- Distributivity Law
+  Look p :<|> Look q -> optGram (Look (optGram (Try p :<|> q)))
+  -- Interchange Law
+  Look (p :$> x) -> optGram (optGram (Look p) :$> x)
+  -- Interchange law
+  Look (f :<$> p) -> optGram (f :<$> optGram (Look p))
+  -- Absorption Law
+  p :<*> NegLook q -> optGram (optGram (p :<*> Pure S.unit) :<* NegLook q)
+  -- Idempotence Law
+  NegLook (p :$> _) -> optGram (NegLook p)
+  -- Idempotence Law
+  NegLook (_ :<$> p) -> optGram (NegLook p)
+  -- Interchange Law
+  Try (p :$> x) -> optGram (optGram (Try p) :$> x)
+  -- Interchange law
+  Try (f :<$> p) -> optGram (f :<$> optGram (Try p))
+
+  -- pure Left/Right laws
+  Branch (Pure (unlift -> lr)) l r ->
+    case getEval lr of
+     Left e -> optGram (l :<*> Pure (S.OptRuntime (Runtime (Eval e) c)))
+      where c = Code [|| case $$(getCode lr) of Left x -> x ||]
+     Right e -> optGram (r :<*> Pure (S.OptRuntime (Runtime (Eval e) c)))
+      where c = Code [|| case $$(getCode lr) of Right x -> x ||]
+  -- Generalised Identity law
+  Branch b (Pure (unlift -> l)) (Pure (unlift -> r)) ->
+    optGram (S.OptRuntime (Runtime e c) :<$> b)
+    where
+    e = Eval (either (getEval l) (getEval r))
+    c = Code [|| either $$(getCode l) $$(getCode r) ||]
+  -- Interchange law
+  Branch (x :*> y) p q ->
+    optGram (x :*> optGram (Branch y p q))
+  -- Negated Branch law
+  Branch b l Empty ->
+    Branch (Pure (S.OptRuntime (Runtime e c)) :<*> b) Empty l
+    where
+    e = Eval (either Right Left)
+    c = Code [||either Right Left||]
+  -- Branch Fusion law
+  Branch (Branch b Empty (Pure (unlift -> lr))) Empty br ->
+    optGram (Branch (optGram (Pure (S.OptRuntime (Runtime (Eval e) c)) :<*> b)) Empty br)
+    where
+    e Left{} = Left ()
+    e (Right r) = case getEval lr r of
+                   Left _ -> Left ()
+                   Right rr -> Right rr
+    c = Code [|| \case Left{} -> Left ()
+                       Right r -> case $$(getCode lr) r of
+                                   Left _ -> Left ()
+                                   Right rr -> Right rr ||]
+  -- Distributivity Law
+  f :<$> Branch b l r -> optGram (Branch b (optGram ((S..@) (S..) f :<$> l))
+                                           (optGram ((S..@) (S..) f :<$> r)))
+
+  x -> x
diff --git a/src/Symantic/Parser/Staging.hs b/src/Symantic/Parser/Staging.hs
new file mode 100644
index 0000000..848f4fc
--- /dev/null
+++ b/src/Symantic/Parser/Staging.hs
@@ -0,0 +1,139 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Symantic.Parser.Staging where
+
+import Data.Bool (Bool)
+import Data.Char (Char)
+import Data.Eq (Eq)
+import Language.Haskell.TH (TExpQ)
+import qualified Data.Eq as Eq
+import qualified Data.Function as Function
+
+import Symantic.Base.Univariant
+
+-- * Type 'Runtime'
+data Runtime a = Runtime
+ { eval :: Eval a
+   -- ^ The value of the runtime code,
+   -- kept along to be made available to the optimizer.
+ , code :: Code a
+   -- ^ An AST of a runtime value.
+ }
+getEval :: Runtime a -> a
+getEval = unEval Function.. eval
+getCode :: Runtime a -> TExpQ a
+getCode = unCode Function.. code
+type instance Unlift Runtime = Runtime
+instance Liftable Runtime where
+  lift = Function.id
+  {-# INLINE lift #-}
+instance Unliftable Runtime where
+  unlift = Function.id
+  {-# INLINE unlift #-}
+
+-- ** Type 'Eval'
+newtype Eval a = Eval { unEval :: a }
+type instance Unlift Eval = Eval
+instance Liftable Eval where
+  lift = Function.id
+  {-# INLINE lift #-}
+instance Unliftable Eval where
+  unlift = Function.id
+  {-# INLINE unlift #-}
+
+-- ** Type 'Code'
+newtype Code a = Code { unCode :: TExpQ a }
+type instance Unlift Code = Code
+instance Liftable Code where
+  lift = Function.id
+  {-# INLINE lift #-}
+instance Unliftable Code where
+  unlift = Function.id
+  {-# INLINE unlift #-}
+
+-- * Class 'Runtimeable'
+-- | Final encoding of some Runtimeable functions
+-- useful for some optimizations in 'optGram'.
+class Runtimeable (repr :: * -> *) where
+  runtime :: Unlift repr a -> repr a
+  (.)   :: repr ((b->c) -> (a->b) -> a -> c)
+  ($)   :: repr ((a->b) -> a -> b)
+  (.@)  :: repr (a->b) -> repr a -> repr b
+  --char  :: Char -> repr Char
+  cons  :: repr (a -> [a] -> [a])
+  const :: repr (a -> b -> a)
+  eq    :: Eq a => repr a -> repr (a -> Bool)
+  flip  :: repr ((a -> b -> c) -> b -> a -> c)
+  id    :: repr (a->a)
+  nil   :: repr [a]
+  unit  :: repr ()
+
+-- ** Type 'Runtimeable'
+-- | Initial encoding of 'Runtimeable'
+data OptRuntime (repr:: * -> *) a where
+  OptRuntime :: repr a -> OptRuntime repr a
+  (:.)  :: OptRuntime repr ((b->c) -> (a->b) -> a -> c)
+  (:$)  :: OptRuntime repr ((a->b) -> a -> b)
+  (:@)  :: OptRuntime repr (a->b) -> OptRuntime repr a -> OptRuntime repr b
+  Const :: OptRuntime repr (a -> b -> a)
+  Flip  :: OptRuntime repr ((a -> b -> c) -> b -> a -> c)
+  Id    :: OptRuntime repr (a->a)
+type instance Unlift (OptRuntime repr) = repr
+instance (Liftable repr, Unliftable repr, Runtimeable repr) => Liftable (OptRuntime repr) where
+  lift = OptRuntime
+instance (Unliftable repr, Runtimeable repr) => Unliftable (OptRuntime repr) where
+  unlift = \case
+   OptRuntime x -> runtime (unlift x)
+   (:.)     -> (.)
+   (:$)     -> ($)
+   (:@) f x -> (.@) (unlift f) (unlift x)
+   Const    -> const
+   Flip     -> flip
+   Id       -> id
+infixr 0 $, :$
+infixr 9 ., :.
+infixl 9 .@, :@
+
+instance Runtimeable (OptRuntime repr) where
+  runtime = OptRuntime
+  (.)   = (:.)
+  ($)   = (:$)
+  (.@)  = (:@)
+  const = Const
+  flip  = Flip
+  id    = Id
+instance Runtimeable Runtime where
+  runtime  = Function.id
+  (.)      = Runtime (.) (.)
+  ($)      = Runtime ($) ($)
+  (.@) f x = Runtime ((.@) (eval f) (eval x)) ((.@) (code f) (code x))
+  cons     = Runtime cons cons
+  const    = Runtime const const
+  eq x     = Runtime (eq (eval x)) (eq (code x))
+  flip     = Runtime flip flip
+  id       = Runtime id id
+  nil      = Runtime nil nil
+  unit     = Runtime unit unit
+instance Runtimeable Eval where
+  runtime  = lift
+  (.)      = Eval (Function..)
+  ($)      = Eval (Function.$)
+  (.@) f x = Eval ((unEval f) (unEval x))
+  cons     = Eval (:)
+  const    = Eval Function.const
+  eq x     = Eval (unEval x Eq.==)
+  flip     = Eval Function.flip
+  id       = Eval Function.id
+  nil      = Eval []
+  unit     = Eval ()
+instance Runtimeable Code where
+  runtime  = lift
+  (.)      = Code [|| \f g x -> f (g x) ||]
+  ($)      = Code [|| \f x -> f x ||]
+  (.@) f x = Code [|| $$(unCode f) $$(unCode x) ||]
+  cons     = Code [|| \x xs -> x : xs ||]
+  const    = Code [|| \x _ -> x ||]
+  eq x     = Code [|| \y -> $$(unCode x) Eq.== y ||]
+  flip     = Code [|| \f x y -> f y x ||]
+  id       = Code [|| \x -> x ||]
+  nil      = Code [|| [] ||]
+  unit     = Code [|| () ||]
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..eb16668
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1 @@
+resolver: nightly-2020-09-03
diff --git a/stack.yaml.lock b/stack.yaml.lock
new file mode 100644
index 0000000..5133aa3
--- /dev/null
+++ b/stack.yaml.lock
@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 528636
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/9/3.yaml
+    sha256: 9dac40ef83b087f8f5c4b32a3400b54f6fc058fd7648e46bbfcb60765b135646
+  original: nightly-2020-09-03
diff --git a/symantic-parser.cabal b/symantic-parser.cabal
new file mode 100644
index 0000000..bca3583
--- /dev/null
+++ b/symantic-parser.cabal
@@ -0,0 +1,62 @@
+name: symantic-parser
+version: 0.0.0.0
+synopsis: Symantic Parser
+description: A Symantic Parser
+license: BSD3
+-- license-file: LICENSE
+-- author:
+-- maintainer:
+-- copyright:
+category: Text
+extra-source-files:
+  stack.yaml
+extra-tmp-files:
+build-type: Simple
+cabal-version: >=1.10
+tested-with: GHC==8.10.2
+
+library
+  hs-source-dirs: src
+  exposed-modules:
+    Symantic.Parser
+    Symantic.Parser.Grammar
+    Symantic.Parser.Grammar.Combinators
+    Symantic.Parser.Grammar.Optimizations
+    Symantic.Parser.Staging
+    Symantic.Base.Univariant
+  other-modules:
+  default-extensions:
+    BangPatterns,
+    DataKinds,
+    FlexibleContexts,
+    FlexibleInstances,
+    GADTs,
+    LambdaCase,
+    MultiParamTypeClasses,
+    NoImplicitPrelude,
+    PolyKinds,
+    RankNTypes,
+    ScopedTypeVariables,
+    TypeApplications,
+    TypeFamilies,
+    TypeOperators
+  build-depends:
+    base >=4.10 && <5,
+    array,
+    bytestring,
+    containers,
+    ghc-prim,
+    hashable,
+    template-haskell >= 2.16,
+    text,
+    unordered-containers
+  default-language: Haskell2010
+  ghc-options:
+    -- -threaded
+    -- -rtsopts
+    -- -with-rtsopts=-N
+    -ddump-splices
+    -ddump-to-file
+    -Wall
+    -Wincomplete-uni-patterns
+    -Wincomplete-record-updates
-- 
2.44.1