diff options
Diffstat (limited to 'stdlib/source/lux/type/opaque.lux')
| -rw-r--r-- | stdlib/source/lux/type/opaque.lux | 164 |
1 files changed, 164 insertions, 0 deletions
diff --git a/stdlib/source/lux/type/opaque.lux b/stdlib/source/lux/type/opaque.lux new file mode 100644 index 000000000..acd73d6a4 --- /dev/null +++ b/stdlib/source/lux/type/opaque.lux @@ -0,0 +1,164 @@ +(;module: + lux + (lux (control [applicative] + [monad #+ do Monad] + ["p" parser]) + (data [text "text/" Eq<Text> Monoid<Text>] + ["E" error] + (coll [list "list/" Functor<List> Monoid<List>])) + [meta] + (meta [code] + ["s" syntax #+ syntax:] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))))) + +(def: (get k plist) + (All [a] + (-> Text (List [Text a]) (Maybe a))) + (case plist + #;Nil + #;None + + (#;Cons [k' v] plist') + (if (text/= k k') + (#;Some v) + (get k plist')))) + +(def: (put k v plist) + (All [a] + (-> Text a (List [Text a]) (List [Text a]))) + (case plist + #;Nil + (list [k v]) + + (#;Cons [k' v'] plist') + (if (text/= k k') + (#;Cons [k' v] plist') + (#;Cons [k' v'] (put k v plist'))))) + +(def: (remove k plist) + (All [a] + (-> Text (List [Text a]) (List [Text a]))) + (case plist + #;Nil + #;Nil + + (#;Cons [k' v'] plist') + (if (text/= k k') + plist' + (#;Cons [k' v'] (remove k plist'))))) + +(def: down-cast Text "@opaque") +(def: up-cast Text "@repr") +(def: macro-anns Code (' {#;macro? true})) + +(def: representation-name + (-> Text Text) + (|>. ($_ text/compose "{" kind "@" module "}") + (let [[module kind] (ident-for #;;Representation)]))) + +(def: (install-casts' this-module-name name type-vars) + (-> Text Text (List Text) (Meta Unit)) + (do meta;Monad<Meta> + [this-module (meta;find-module this-module-name) + #let [type-varsC (list/map code;local-symbol type-vars) + opaque-declaration (` ((~ (code;local-symbol name)) (~@ type-varsC))) + representation-declaration (` ((~ (code;local-symbol (representation-name name))) (~@ type-varsC))) + this-module (|> this-module + (update@ #;defs (put down-cast (: Def + [Macro macro-anns + (function [tokens] + (case tokens + (^ (list value)) + (wrap (list (` ((: (All [(~@ type-varsC)] + (-> (~ representation-declaration) (~ opaque-declaration))) + (|>. :!!)) + (~ value))))) + + _ + (meta;fail ($_ text/compose "Wrong syntax for " down-cast))))]))) + (update@ #;defs (put up-cast (: Def + [Macro macro-anns + (function [tokens] + (case tokens + (^ (list value)) + (wrap (list (` ((: (All [(~@ type-varsC)] + (-> (~ opaque-declaration) (~ representation-declaration))) + (|>. :!!)) + (~ value))))) + + _ + (meta;fail ($_ text/compose "Wrong syntax for " up-cast))))]))))]] + (function [compiler] + (#E;Success [(update@ #;modules (put this-module-name this-module) compiler) + []])))) + +(def: (un-install-casts' this-module-name) + (-> Text (Meta Unit)) + (do meta;Monad<Meta> + [this-module (meta;find-module this-module-name) + #let [this-module (|> this-module + (update@ #;defs (remove down-cast)) + (update@ #;defs (remove up-cast)))]] + (function [compiler] + (#E;Success [(update@ #;modules (put this-module-name this-module) compiler) + []])))) + +(syntax: #hidden (install-casts [name s;local-symbol] + [type-vars (s;tuple (p;some s;local-symbol))]) + (do @ + [this-module-name meta;current-module-name + ?down-cast (meta;find-macro [this-module-name down-cast]) + ?up-cast (meta;find-macro [this-module-name up-cast])] + (case [?down-cast ?up-cast] + [#;None #;None] + (do @ + [_ (install-casts' this-module-name name type-vars)] + (wrap (list))) + + _ + (meta;fail ($_ text/compose + "Cannot temporarily define casting functions (" + down-cast " & " up-cast + ") because definitions like that already exist."))))) + +(syntax: #hidden (un-install-casts) + (do meta;Monad<Meta> + [this-module-name meta;current-module-name + ?down-cast (meta;find-macro [this-module-name down-cast]) + ?up-cast (meta;find-macro [this-module-name up-cast])] + (case [?down-cast ?up-cast] + [(#;Some _) (#;Some _)] + (do @ + [_ (un-install-casts' this-module-name)] + (wrap (list))) + + _ + (meta;fail ($_ text/compose + "Cannot un-define casting functions (" + down-cast " & " up-cast + ") because they do not exist."))))) + +(def: declaration + (s;Syntax [Text (List Text)]) + (p;either (s;form (p;seq s;local-symbol (p;some s;local-symbol))) + (p;seq s;local-symbol (:: p;Monad<Parser> wrap (list))))) + +(syntax: #export (opaque: [export csr;export] + [[name type-vars] declaration] + [annotations (p;default cs;empty-annotations csr;annotations)] + representation-type + [primitives (p;some s;any)]) + (let [hidden-name (code;local-symbol (representation-name name)) + type-varsC (list/map code;local-symbol type-vars) + opaque-declaration (` ((~ (code;local-symbol name)) (~@ type-varsC))) + representation-declaration (` ((~ hidden-name) (~@ type-varsC)))] + (wrap (list& (` (type: (~@ (csw;export export)) (~ opaque-declaration) + (~ (csw;annotations annotations)) + (primitive (~ hidden-name) [(~@ type-varsC)]))) + (` (type: (~@ (csw;export export)) (~ representation-declaration) + (~ representation-type))) + (` (install-casts (~ (code;local-symbol name)) [(~@ type-varsC)])) + (list/compose primitives + (list (` (un-install-casts)))))))) |