suckless-script extension

lib/Data/Config/Suckless/Script/File.hs

@@ -15,6 +15,8 @@ import System.FilePath
 import System.FilePattern
 import Data.HashSet qualified as HS
 
+import Prettyprinter
+
 import Lens.Micro.Platform
 import UnliftIO
 import Control.Concurrent.STM qualified as STM
@@ -67,12 +69,12 @@ entries = do
   entry $ bindMatch "glob" $ \syn -> do
 
     (p,i,d) <- case syn of
-                 [] -> pure (["*"], [], ".")
+                 [] -> pure (["**/*"], ["**/.*"], ".")
 
-                 [StringLike d, StringLike i, StringLike e] -> do
+                 s@[StringLike d, ListVal (StringLikeList i) ] -> do
-                    pure ([i], [e], d)
+                    pure (i, [], d)
 
-                 [StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e)] -> do
+                 s@[StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e) ] -> do
                     pure (i, e, d)
 
                  _ -> throwIO (BadFormException @c nil)

lib/Data/Config/Suckless/Script/Internal.hs

@@ -2,6 +2,7 @@
 {-# Language UndecidableInstances #-}
 {-# Language PatternSynonyms #-}
 {-# Language ViewPatterns #-}
+{-# Language RecordWildCards #-}
 module Data.Config.Suckless.Script.Internal
   ( module Data.Config.Suckless.Script.Internal
   , module Export
@@ -16,6 +17,8 @@ import Control.Monad.Reader
 import Control.Monad.Writer
 import Data.ByteString (ByteString)
 import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
 import Data.Data
 import Data.Function as Export
 import Data.Functor as Export
@@ -30,6 +33,8 @@ import Data.String
 import Data.Text.IO qualified as TIO
 import Data.Text qualified as Text
 import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (ignore)
 import Data.Time.Clock.POSIX
 import GHC.Generics hiding (C)
 import Prettyprinter
@@ -116,7 +121,7 @@ instance IsString ManDesc where
 instance Pretty (Man a) where
   pretty e =   "NAME"
              <> line
-             <> indent 8 (pretty (manName e) <> fmtBrief e)
+             <> indent 4 (pretty (manName e) <> fmtBrief e)
              <> line
              <> fmtSynopsis
              <> fmtDescription
@@ -131,14 +136,14 @@ instance Pretty (Man a) where
       Nothing -> mempty
       Just (ManReturns t s) ->
         line <> "RETURN VALUE" <> line
-        <> indent 8 (
+        <> indent 4 (
             if not (Text.null s) then
               (pretty t <> hsep ["","-",""] <> pretty s) <> line
             else pretty t )
 
     fmtDescription = line
       <> "DESCRIPTION" <> line
-      <> indent 8 ( case manDesc e of
+      <> indent 4 ( case manDesc e of
            Nothing -> pretty (manBrief e)
            Just x  -> pretty x)
       <> line
@@ -157,13 +162,13 @@ instance Pretty (Man a) where
       es -> line
         <> "EXAMPLES"
         <> line
-        <> indent 8 ( vcat (fmap pretty es) )
+        <> indent 4 ( vcat (fmap pretty es) )
 
     synEntry (ManSynopsis (ManApply [])) =
-      indent 8 ( parens (pretty (manName e)) ) <> line
+      indent 4 ( parens (pretty (manName e)) ) <> line
 
     synEntry (ManSynopsis (ManApply xs)) = do
-      indent 8 do
+      indent 4 do
         parens (pretty (manName e) <+>
          hsep [ pretty n | ManApplyArg t n <- xs ]  )
          <> line
@@ -264,6 +269,12 @@ eatNil f = \case
 class IsContext c => MkInt c s where
   mkInt :: s -> Syntax c
 
+class IsContext c => MkDouble c s where
+  mkDouble :: s -> Syntax c
+
+instance (IsContext c, RealFrac s) => MkDouble c s where
+  mkDouble v = Literal noContext $ LitScientific (realToFrac v)
+
 instance (Integral i, IsContext c) => MkInt c i where
   mkInt n = Literal noContext $ LitInt (fromIntegral n)
 
@@ -332,18 +343,11 @@ newtype NameNotBoundException =
   deriving stock Show
   deriving newtype (Generic,Typeable)
 
-newtype NotLambda = NotLambda Id
-                    deriving stock Show
-                    deriving newtype (Generic,Typeable)
-
-instance Exception NotLambda
 
 data BadFormException c = BadFormException (Syntax c)
                         | ArityMismatch (Syntax c)
-
+                        | NotLambda (Syntax c)
-newtype TypeCheckError c = TypeCheckError (Syntax c)
+                        | TypeCheckError (Syntax c)
-
-instance Exception (TypeCheckError C)
 
 newtype BadValueException = BadValueException String
                             deriving stock Show
@@ -354,8 +358,7 @@ instance Exception NameNotBoundException
 instance IsContext c => Show (BadFormException c) where
   show (BadFormException sy) = show $ "BadFormException" <+> pretty sy
   show (ArityMismatch sy) = show $ "ArityMismatch" <+> pretty sy
-
+  show (NotLambda sy) = show $ "NotLambda" <+> pretty sy
-instance IsContext c => Show (TypeCheckError c) where
   show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy
 
 instance Exception (BadFormException C)
@@ -434,7 +437,7 @@ opt n d = n <+> "-" <+> d
 examples :: ManExamples -> MakeDictM c m () -> MakeDictM c m ()
 examples (ManExamples s) = censor (HM.map setExamples )
   where
-    ex = ManExamples (Text.unlines $ Text.strip <$> Text.lines (Text.strip s))
+    ex = ManExamples (Text.unlines $ Text.lines (Text.strip s))
     ex0 = mempty { manExamples = [ex] }
     setExamples (Bind w x) = Bind (Just (maybe ex0 (<>ex0) w)) x
 
@@ -485,9 +488,11 @@ apply_ :: forall c m . ( IsContext c
 
 apply_ s args = case s of
   ListVal [SymbolVal "builtin:lambda", SymbolVal n]  -> apply n args
+  SymbolVal "quot"       -> pure $ mkList args
+  SymbolVal "quasiquot"  -> mkList <$> mapM evalQQ args
   SymbolVal   what  -> apply what args
   Lambda d body     -> applyLambda d body args
-  e -> throwIO $ BadFormException @c s
+  e                  -> throwIO $ NotLambda e
 
 apply :: forall c m . ( IsContext c
                       , MonadUnliftIO m
@@ -496,6 +501,13 @@ apply :: forall c m . ( IsContext c
       => Id
       -> [Syntax c]
       -> RunM c m (Syntax c)
+
+apply "quot" args = do
+  pure $ mkList args
+
+apply "quasiquot" args = do
+  mkList <$> mapM evalQQ args
+
 apply name args' = do
   -- notice $ red "APPLY" <+> pretty name
   what <- ask >>=  readTVarIO <&> HM.lookup name
@@ -507,7 +519,7 @@ apply name args' = do
       applyLambda argz body args'
 
     Just (BindValue _) -> do
-      throwIO (NotLambda name)
+      throwIO (NotLambda (mkSym @c name))
 
     Nothing -> throwIO (NameNotBound name)
 
@@ -543,6 +555,20 @@ bindBuiltins  dict = do
   atomically do
     modifyTVar t (<> dict)
 
+
+evalQQ :: forall c m . ( IsContext c
+                     , MonadUnliftIO m
+                     , Exception (BadFormException c)
+                     ) => Syntax c -> RunM c m (Syntax c)
+evalQQ = \case
+  SymbolVal (Id w) | Text.isPrefixOf "," w -> do
+    let what = Id (Text.drop 1 w)
+    lookupValue what >>= eval
+
+  List c es   -> List c <$> mapM evalQQ es
+
+  other       -> pure other
+
 eval :: forall c m . ( IsContext c
                      , MonadUnliftIO m
                      , Exception (BadFormException c)
@@ -551,11 +577,34 @@ eval syn = handle (handleForm syn) $ do
 
     dict <- ask >>= readTVarIO
 
+    -- liftIO $ print $ show $ "TRACE EXP" <+> pretty syn
+
     case syn of
 
+      SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
+        pure (mkSym @c (Text.drop 1 s))
+
       ListVal [ w, SymbolVal ".", b] -> do
         pure  $ mkList  [w, b]
 
+      ListVal [ SymbolVal ":", b] -> do
+        pure  $ mkList [b]
+
+      ListVal [ SymbolVal "'", ListVal b] -> do
+        pure  $ mkList b
+
+      ListVal [ SymbolVal "'", StringLike x] -> do
+        pure  $ mkSym x
+
+      ListVal [ SymbolVal "'", x] -> do
+        pure  x
+
+      ListVal [ SymbolVal "`", ListVal b] -> do
+        mkList <$> mapM evalQQ b
+
+      ListVal [ SymbolVal "quasiquot", ListVal b] -> do
+        mkList <$> mapM evalQQ b
+
       ListVal [ SymbolVal "quot", ListVal b] -> do
         pure  $ mkList  b
 
@@ -591,8 +640,9 @@ eval syn = handle (handleForm syn) $ do
       ListVal (SymbolVal name : args') -> do
         apply name args'
 
-      SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
+      ListVal (e' : args') -> do
-        pure (mkSym @c (Text.drop 1 s))
+        -- e <- eval e'
+        apply_ e' args'
 
       SymbolVal name | HM.member name dict -> do
         let what = HM.lookup name dict
@@ -607,7 +657,7 @@ eval syn = handle (handleForm syn) $ do
 
       e@Literal{} -> pure e
 
-      e -> throwIO $ BadFormException @c e
+      e -> throwIO $ NotLambda @c e
 
   where
     handleForm syn = \case
@@ -615,6 +665,9 @@ eval syn = handle (handleForm syn) $ do
         throwIO (BadFormException syn)
       (ArityMismatch s  :: BadFormException c) -> do
         throwIO (ArityMismatch syn)
+      (TypeCheckError s  :: BadFormException c) -> do
+        throwIO (TypeCheckError syn)
+      other -> throwIO other
 
 runM :: forall c m a. ( IsContext c
                       , MonadUnliftIO m
@@ -632,6 +685,13 @@ run d sy = do
   tvd <- newTVarIO d
   lastDef nil <$> runReaderT (fromRunM (mapM eval sy)) tvd
 
+runEval :: forall c m . ( IsContext c
+                    , MonadUnliftIO m
+                    , Exception (BadFormException c)
+                    ) => TVar (Dict c m) -> [Syntax c] -> m (Syntax c)
+runEval tvd sy = do
+  lastDef nil <$> runReaderT (fromRunM (mapM eval sy)) tvd
+
 evalTop :: forall c m . ( IsContext c
                         , MonadUnliftIO m
                         , Exception (BadFormException c))
@@ -647,20 +707,29 @@ bindMatch n fn = HM.singleton n (Bind man (BindLambda fn))
 bindValue :: Id -> Syntax c -> Dict c m
 bindValue n e = HM.singleton n (Bind mzero (BindValue e))
 
+lookupValue :: forall c m . (IsContext c, MonadUnliftIO m)
+            => Id -> RunM c m (Syntax c)
+lookupValue i = do
+  ask  >>= readTVarIO
+       <&> (fmap bindAction . HM.lookup i)
+       >>= \case
+          Just (BindValue s) -> pure s
+          _  -> throwIO (NameNotBound i)
+
 nil :: forall c . IsContext c => Syntax c
 nil = List noContext []
 
 nil_ :: (IsContext c, MonadIO m) =>  (a -> RunM c m b) -> a -> RunM c m (Syntax c)
 nil_ m w = m w >> pure (List noContext [])
 
-fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2
+fixContext :: forall c1 c2 . (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2
 fixContext = go
   where
     go = \case
       List    _ xs -> List noContext (fmap go xs)
       Symbol  _ w  -> Symbol noContext w
       Literal _ l  -> Literal noContext l
-
+      OpaqueValue box  -> OpaqueValue box
 
 fmt :: Syntax c -> Doc ann
 fmt = \case
@@ -770,6 +839,23 @@ internalEntries = do
       z ->
         throwIO (BadFormException @C nil)
 
+
+    entry $ bindMatch "eval" $ \syn -> do
+      r <- mapM eval syn
+      pure $ lastDef nil r
+
+    entry $ bindMatch "id" $ \case
+      [ e ] -> pure e
+      _ -> throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "inc" $ \case
+      [ LitIntVal n ] -> pure (mkInt (succ n))
+      _ -> throwIO (TypeCheckError @C  nil)
+
+    entry $ bindMatch "dec" $ \case
+      [ LitIntVal n ] -> pure (mkInt (succ n))
+      _ -> throwIO (TypeCheckError @C  nil)
+
     entry $ bindMatch "map" $ \syn -> do
       case syn of
         [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
@@ -783,6 +869,16 @@ internalEntries = do
         _ -> do
           throwIO (BadFormException @C nil)
 
+    entry $ bindMatch "quot" $ \case
+      [ syn ] -> pure $ mkList [syn]
+      _ -> do
+          throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "quasiquot" $ \case
+      [ syn ] -> mkList . List.singleton <$> evalQQ syn
+      _ -> do
+          throwIO (BadFormException @C nil)
+
     entry $ bindMatch "head" $ \case
       [ ListVal es ] -> pure (head es)
       _ -> throwIO (TypeCheckError @C nil)
@@ -822,6 +918,61 @@ internalEntries = do
       [ sy ] -> display sy
       ss     -> display (mkList ss)
 
+    let colorz = HM.fromList
+          [ ("red",     pure (Red, True))
+          , ("red~",    pure (Red, False))
+          , ("green",   pure (Green, True))
+          , ("green~",  pure (Green, False))
+          , ("yellow",  pure (Yellow, True))
+          , ("yellow~", pure (Yellow, False))
+          , ("blue",    pure (Blue, True))
+          , ("blue~",   pure (Blue, False))
+          , ("magenta", pure (Magenta, True))
+          , ("magenta~",pure (Magenta, False))
+          , ("cyan",    pure (Cyan, True))
+          , ("cyan~",   pure (Cyan, False))
+          , ("white",   pure (White, True))
+          , ("white~",  pure (White, False))
+          , ("black",   pure (Black, True))
+          , ("black~",  pure (Black, False))
+          , ("_",       mzero)
+          ]
+
+
+    let fgc fg = case join (HM.lookup fg colorz) of
+          Just (co, True)  -> color co
+          Just (co, False) -> colorDull co
+          Nothing             -> mempty
+
+    let niceTerm f = \case
+          LitStrVal x -> do
+            let s = renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty x)
+            mkStr s
+
+          other -> do
+            let s = renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty other)
+            mkStr s
+
+    entry $ bindMatch "ansi" $  \case
+      [ SymbolVal fg, SymbolVal bg, term ] | HM.member fg colorz && HM.member bg colorz -> do
+        let b = case join (HM.lookup bg colorz) of
+                  Just (co, True)  -> bgColor co
+                  Just (co, False) -> bgColorDull co
+                  Nothing -> mempty
+
+        let f = b <> fgc fg
+        pure $ niceTerm f term
+
+      [ SymbolVal fg, s] | HM.member fg colorz -> do
+        let f = fgc fg
+        pure $ niceTerm f s
+        -- let wtf = show $ pretty s
+        -- let x = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions (annotate f $ pretty wtf)
+        -- -- error $ show x
+        -- pure $ mkStr x
+
+      _  -> throwIO (BadFormException @c nil)
+
     brief "prints new line character to stdout"
       $ entry $ bindMatch "newline" $ nil_ $ \case
           [] -> liftIO (putStrLn "")
@@ -836,7 +987,7 @@ internalEntries = do
       [ sy ] -> display sy >> liftIO (putStrLn "")
       ss     -> mapM_ display ss >> liftIO (putStrLn "")
 
-    entry $ bindMatch "str:read-stdin" $ \case
+    entry $ bindMatch "str:stdin" $ \case
       [] -> liftIO getContents <&> mkStr @c
 
       _ -> throwIO (BadFormException @c nil)
@@ -846,7 +997,7 @@ internalEntries = do
       _ -> throwIO (BadFormException @c nil)
 
     brief "reads file as a string" do
-      entry $ bindMatch "str:read-file" $ \case
+      entry $ bindMatch "str:file" $ \case
         [StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr
 
         _ -> throwIO (BadFormException @c nil)
@@ -859,13 +1010,39 @@ internalEntries = do
 
     entry $ bindValue "space" $ mkStr " "
 
-    entry $ bindMatch "parse-top" $ \case
+    let doParseTop w l s =
+         parseTop s & either (const nil) (mkForm w . fmap ( l . fixContext) )
+
+    let wrapWith e = \case
+          List c es -> List c (e : es)
+          other     -> other
+    let lwrap = \case
+          e@(SymbolVal x) -> wrapWith e
+          _ -> id
+
+    brief "parses string as toplevel and produces a form"
+     $ desc "parse:top:string SYMBOL STRING-LIKE"
+     $ entry $ bindMatch "parse:top:string" $ \case
 
         [SymbolVal w, LitStrVal s] -> do
-        pure $  parseTop s & either (const nil) (mkForm w . fmap fixContext)
+          pure $  doParseTop w id s
 
-      [LitStrVal s] -> do
+        [SymbolVal w, e@(SymbolVal r), LitStrVal s] -> do
-        pure $  parseTop s & either (const nil) (mkList . fmap fixContext)
+          pure $  doParseTop w (lwrap e) s
+
+        _ -> throwIO (BadFormException @c nil)
+
+    brief "parses file as toplevel form and produces a form"
+     $ desc "parse:top:file SYMBOL <FILENAME>"
+     $ entry $ bindMatch "parse:top:file" $ \case
+
+        [SymbolVal w, StringLike fn] -> do
+          s <- liftIO $ TIO.readFile fn
+          pure $  doParseTop w id s
+
+        [SymbolVal w, e@(SymbolVal r), StringLike fn] -> do
+          s <- liftIO $ TIO.readFile fn
+          pure $  doParseTop w (lwrap e)  s
 
         _ -> throwIO (BadFormException @c nil)
 
@@ -967,3 +1144,60 @@ internalEntries = do
       _ -> throwIO (BadFormException @c nil)
 
 
+    brief "decodes bytes as utf8 text"
+     $ desc "bytes:decode <BYTES>"
+     $ entry $ bindMatch "bytes:decode" $ \case
+        [ OpaqueVal box ] -> do
+
+          let lbs' = fromOpaque @LBS.ByteString box
+                      <|>
+                     (LBS.fromStrict <$> fromOpaque @BS.ByteString box)
+
+          lbs <- maybe (throwIO (UnexpectedType "unknown / ByteString")) pure lbs'
+
+          -- TODO: maybe-throw-on-invalid-encoding
+          let txt = decodeUtf8With ignore (LBS.toStrict lbs)
+
+          pure $ mkStr txt
+
+        _ -> throwIO (BadFormException @c nil)
+
+
+    brief "reads bytes from a file"
+     $ desc "bytes:file FILE"
+     $ entry $ bindMatch "bytes:file" $ \case
+        [ StringLike fn ] -> do
+          liftIO (LBS.readFile fn) >>= mkOpaque
+
+        _ -> throwIO (BadFormException @c nil)
+
+    brief "reads bytes from a STDIN"
+     $ desc "bytes:stdin"
+     $ entry $ bindMatch "bytes:stdin" $ \case
+        [] -> do
+          liftIO LBS.getContents >>= mkOpaque
+
+        _ -> throwIO (BadFormException @c nil)
+
+    brief "writes bytes to STDOUT"
+     $ desc "bytes:put <BYTES>"
+     $ entry $ bindMatch "bytes:put" $ nil_ $ \case
+        [isOpaqueOf @LBS.ByteString -> Just s ] -> do
+          liftIO $ LBS.putStr s
+
+        [isOpaqueOf @ByteString -> Just s ] -> do
+          liftIO $ BS.putStr s
+
+        _ -> throwIO (BadFormException @c nil)
+
+    brief "writes bytes to FILE"
+     $ desc "bytes:write <FILE> <BYTES>"
+     $ entry $ bindMatch "bytes:write" $ nil_ $ \case
+        [StringLike fn, isOpaqueOf @LBS.ByteString -> Just s ] -> do
+          liftIO $ LBS.writeFile fn s
+
+        [StringLike fn, isOpaqueOf @ByteString -> Just s ] -> do
+          liftIO $ BS.writeFile fn s
+
+        _ -> throwIO (BadFormException @c nil)
+

lib/Data/Config/Suckless/Syntax.hs

@@ -4,15 +4,24 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# Language ViewPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
 module Data.Config.Suckless.Syntax
   ( Syntax(..)
   , Id(..)
   , Literal(..)
+  , Opaque(..)
   , HasContext
   , C(..)
   , Context(..)
   , IsContext(..)
   , IsLiteral(..)
+  , ByteStringSorts(..)
+  , mkOpaque
+  , isOpaqueOf
+  , fromOpaque
+  , fromOpaqueThrow
+  , isByteString
+  , SyntaxTypeError(..)
   , pattern SymbolVal
   , pattern ListVal
   , pattern LitIntVal
@@ -22,25 +31,35 @@ module Data.Config.Suckless.Syntax
   , pattern StringLike
   , pattern StringLikeList
   , pattern Nil
+  , pattern OpaqueVal
   )
   where
 
 import Data.Data
+import Data.Dynamic
 import Data.Kind
 import Data.String
 import Data.Text (Text)
 import Data.Scientific
 import GHC.Generics (Generic(..))
 import Data.Maybe
--- import GHC.Generics( Fixity(..) )
--- import Data.Data as Data
 import Data.Aeson
 import Data.Aeson.Key
 import Data.Aeson.KeyMap qualified as Aeson
 import Data.Vector qualified as V
 import Data.Traversable (forM)
 import Data.Text qualified as Text
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LBS
 import Data.Function
+import Data.Functor
+import Control.Applicative
+import Control.Exception
+import Type.Reflection
+import Control.Monad.IO.Class
+import System.IO.Unsafe (unsafePerformIO)
+import Data.IORef
+import Data.Word
 
 import Prettyprinter
 
@@ -73,6 +92,8 @@ stringLike = \case
 stringLikeList :: [Syntax c] -> [String]
 stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
 
+data ByteStringSorts = ByteStringLazy LBS.ByteString | ByteStringStrict ByteString
+
 
 pattern StringLike :: forall {c} . String -> Syntax c
 pattern StringLike e <- (stringLike -> Just e)
@@ -84,10 +105,25 @@ pattern StringLikeList e <- (stringLikeList -> e)
 pattern Nil :: forall {c} . Syntax c
 pattern Nil <- ListVal []
 
-
+pattern OpaqueVal :: forall {c} . Opaque -> Syntax c
+pattern OpaqueVal box <- OpaqueValue box
 
 data family Context c :: Type
 
+isOpaqueOf :: forall a c . (Typeable a, IsContext c) => Syntax c -> Maybe a
+isOpaqueOf = \case
+ OpaqueValue box -> fromOpaque @a box
+ _ -> Nothing
+
+isByteString :: Syntax c -> Maybe ByteStringSorts
+isByteString = \case
+  OpaqueValue box -> do
+    let lbs = fromOpaque @LBS.ByteString box <&> ByteStringLazy
+    let bs = fromOpaque @ByteString box <&> ByteStringStrict
+    lbs <|> bs
+
+  _ -> Nothing
+
 class IsContext c where
   noContext :: Context c
 
@@ -106,6 +142,63 @@ newtype Id =
   deriving newtype (IsString,Pretty)
   deriving stock (Data,Generic,Show,Eq,Ord)
 
+type ForOpaque a = (Typeable a, Eq a)
+
+data Opaque = forall a. ForOpaque a =>
+  Opaque
+  { opaqueProxy :: !(Proxy a)
+  , opaqueId    :: !Word64
+  , opaqueRep   :: !SomeTypeRep
+  , opaqueDyn   :: !Dynamic
+  }
+
+opaqueIdIORef :: IORef Word64
+opaqueIdIORef = unsafePerformIO (newIORef 1)
+{-# NOINLINE opaqueIdIORef #-}
+
+mkOpaque :: forall c a m . (MonadIO m, ForOpaque a) => a -> m (Syntax c)
+mkOpaque x = do
+  n <- liftIO $ atomicModifyIORef opaqueIdIORef (\n -> (succ n,n))
+  pure $ OpaqueValue $ Opaque (Proxy :: Proxy a) n (someTypeRep (Proxy :: Proxy a)) (toDyn x)
+
+data SyntaxTypeError =
+  UnexpectedType String
+  deriving stock (Show,Typeable)
+
+instance Exception SyntaxTypeError
+
+fromOpaque :: forall a. Typeable a => Opaque -> Maybe a
+fromOpaque (Opaque{..}) = fromDynamic opaqueDyn
+
+fromOpaqueThrow :: forall a m . (MonadIO m, Typeable a) => String -> Opaque -> m a
+fromOpaqueThrow s (Opaque{..}) = do
+  let o = fromDynamic @a opaqueDyn
+  liftIO $ maybe (throwIO (UnexpectedType s)) pure o
+
+instance Eq Opaque where
+  (Opaque p1 _  t1 d1) == (Opaque _ _ t2 d2) =
+    t1 == t2 && unpack p1 d1 == unpack p1 d2
+    where
+      unpack :: forall a . (Typeable a) => Proxy a -> Dynamic -> Maybe a
+      unpack _ = fromDynamic @a
+
+-- Partial Data implementation for Opaque
+instance Data Opaque where
+  gfoldl _ z (Opaque{..}) = z (Opaque{..})
+
+  -- Can not be unfolded
+  gunfold _ z _ = z (Opaque (Proxy :: Proxy ()) 0 (someTypeRep (Proxy :: Proxy ())) (toDyn ()))
+
+  toConstr _ = opaqueConstr
+  dataTypeOf _ = opaqueDataType
+
+opaqueConstr :: Constr
+opaqueConstr = mkConstr opaqueDataType "Opaque" [] Prefix
+
+opaqueDataType :: DataType
+opaqueDataType = mkDataType "Opaque" [opaqueConstr]
+
+
 data Literal =
     LitStr   Text
   | LitInt   Integer
@@ -141,13 +234,14 @@ data Syntax c
   = List    (Context c) [Syntax c]
   | Symbol  (Context c) Id
   | Literal (Context c) Literal
+  | OpaqueValue Opaque
   deriving stock (Generic,Typeable)
 
-
 instance Eq (Syntax c) where
   (==) (Literal _ a) (Literal _ b) = a == b
   (==) (Symbol _ a)  (Symbol _ b) = a == b
   (==) (List _ a)    (List _ b) = a == b
+  (==) (OpaqueValue a) (OpaqueValue b) = a == b
   (==) _ _ = False
 
 deriving instance (Data c, Data (Context c)) => Data (Syntax c)
@@ -157,6 +251,7 @@ instance Pretty (Syntax c) where
   pretty (Symbol _ s)    = pretty s
   pretty (List _ (x:xs)) = parens $ align $ sep ( fmap pretty (x:xs) )
   pretty (List _ [])     = parens mempty
+  pretty (OpaqueValue v) = "#opaque:" <> viaShow (opaqueRep v) <> ":" <> pretty (opaqueId v)
 
 instance Pretty Literal where
   pretty = \case
@@ -175,6 +270,7 @@ instance ToJSON Literal where
     toJSON (LitBool b)      = Bool b
 
 instance ToJSON (Syntax c) where
+    toJSON (OpaqueValue{}) = Null
     toJSON (Symbol _ (Id "#nil")) = Null
     toJSON (Symbol _ (Id s)) = String s
     toJSON (Literal _ l) = toJSON l