From ca2e824cdffaca83b7a97540422821fe2ac4d439 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Mon, 7 Oct 2024 05:23:16 +0300 Subject: [PATCH] suckless-script extension --- lib/Data/Config/Suckless/Script/File.hs | 10 +- lib/Data/Config/Suckless/Script/Internal.hs | 300 +++++++++++++++++--- lib/Data/Config/Suckless/Syntax.hs | 106 ++++++- 3 files changed, 374 insertions(+), 42 deletions(-) diff --git a/lib/Data/Config/Suckless/Script/File.hs b/lib/Data/Config/Suckless/Script/File.hs index e6fa848..3e4afaf 100644 --- a/lib/Data/Config/Suckless/Script/File.hs +++ b/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 - pure ([i], [e], d) + s@[StringLike d, ListVal (StringLikeList i) ] -> do + 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) diff --git a/lib/Data/Config/Suckless/Script/Internal.hs b/lib/Data/Config/Suckless/Script/Internal.hs index cb6f83a..30aad28 100644 --- a/lib/Data/Config/Suckless/Script/Internal.hs +++ b/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) - -newtype TypeCheckError c = TypeCheckError (Syntax c) - -instance Exception (TypeCheckError C) + | NotLambda (Syntax c) + | TypeCheckError (Syntax 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 - -instance IsContext c => Show (TypeCheckError c) where + show (NotLambda sy) = show $ "NotLambda" <+> pretty sy 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 - pure (mkSym @c (Text.drop 1 s)) + ListVal (e' : args') -> do + -- 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,15 +1010,41 @@ 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) ) - [SymbolVal w, LitStrVal s] -> do - pure $ parseTop s & either (const nil) (mkForm w . fmap fixContext) + let wrapWith e = \case + List c es -> List c (e : es) + other -> other + let lwrap = \case + e@(SymbolVal x) -> wrapWith e + _ -> id - [LitStrVal s] -> do - pure $ parseTop s & either (const nil) (mkList . fmap fixContext) + brief "parses string as toplevel and produces a form" + $ desc "parse:top:string SYMBOL STRING-LIKE" + $ entry $ bindMatch "parse:top:string" $ \case - _ -> throwIO (BadFormException @c nil) + [SymbolVal w, LitStrVal s] -> do + pure $ doParseTop w id s + + [SymbolVal w, e@(SymbolVal r), LitStrVal s] -> do + 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 " + $ 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) let atomFrom = \case [StringLike s] -> pure (mkSym s) @@ -967,3 +1144,60 @@ internalEntries = do _ -> throwIO (BadFormException @c nil) + brief "decodes bytes as utf8 text" + $ desc "bytes:decode " + $ 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 " + $ 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 " + $ 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) + diff --git a/lib/Data/Config/Suckless/Syntax.hs b/lib/Data/Config/Suckless/Syntax.hs index f87e418..9067aef 100644 --- a/lib/Data/Config/Suckless/Syntax.hs +++ b/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,11 +142,68 @@ 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 | LitScientific Scientific - | LitBool Bool + | LitBool Bool deriving stock (Eq,Ord,Data,Generic,Show) instance IsLiteral Text where @@ -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