aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/type/model.lux188
1 files changed, 188 insertions, 0 deletions
diff --git a/stdlib/source/lux/type/model.lux b/stdlib/source/lux/type/model.lux
new file mode 100644
index 000000000..757640b3c
--- /dev/null
+++ b/stdlib/source/lux/type/model.lux
@@ -0,0 +1,188 @@
+(;module:
+ lux
+ (lux (control [applicative]
+ [monad #+ do Monad]
+ ["p" parser "p/" Monad<Parser>])
+ (data [text "text/" Eq<Text>]
+ text/format
+ ["R" result]
+ (coll [list "L/" Functor<List> Monoid<List>]))
+ [macro #+ Monad<Lux>]
+ (macro [code]
+ ["s" syntax #+ syntax:]
+ (syntax ["cs" common]
+ (common ["csr" reader]
+ ["csw" writer])))
+ type/auto))
+
+(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 "@model")
+(def: up-cast Text "@repr")
+(def: macro-anns Anns (list [["lux" "macro?"] (#;BoolA true)]))
+
+(do-template [<name> <tag>]
+ [(def: <name>
+ (-> Text Text)
+ (|>. (format "{" kind "@" module "}")
+ (let [[module kind] (ident-for <tag>)])))]
+
+ [representation-name #;;Representation]
+ [down-cast-name #;;Down-Cast]
+ [up-cast-name #;;Up-Cast]
+ )
+
+(def: (install-casts' this-module-name name type-vars)
+ (-> Text Text (List Text) (Lux Unit))
+ (do Monad<Lux>
+ [this-module (macro;find-module this-module-name)
+ #let [this-module (|> this-module
+ (update@ #;defs (put down-cast (: Def
+ [Macro macro-anns
+ (function [tokens]
+ (case tokens
+ (^ (list value))
+ (wrap (list (if (list;empty? type-vars)
+ (` (|> (~ value)
+ (: (~ (code;local-symbol (representation-name name))))
+ (:! (~ (code;local-symbol name)))))
+ (` ((~ (code;local-symbol (down-cast-name name)))
+ (~ value))))))
+
+ _
+ (macro;fail (format "Wrong syntax for " down-cast))))])))
+ (update@ #;defs (put up-cast (: Def
+ [Macro macro-anns
+ (function [tokens]
+ (case tokens
+ (^ (list value))
+ (wrap (list (if (list;empty? type-vars)
+ (` (|> (~ value)
+ (: (~ (code;local-symbol name)))
+ (:! (~ (code;local-symbol (representation-name name))))))
+ (` ((~ (code;local-symbol (up-cast-name name)))
+ (~ value))))))
+
+ _
+ (macro;fail (format "Wrong syntax for " up-cast))))]))))]]
+ (function [compiler]
+ (#R;Success [(update@ #;modules (put this-module-name this-module) compiler)
+ []]))))
+
+(def: (un-install-casts' this-module-name)
+ (-> Text (Lux Unit))
+ (do Monad<Lux>
+ [this-module (macro;find-module this-module-name)
+ #let [this-module (|> this-module
+ (update@ #;defs (remove down-cast))
+ (update@ #;defs (remove up-cast)))]]
+ (function [compiler]
+ (#R;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 macro;current-module-name
+ ?down-cast (macro;find-macro [this-module-name down-cast])
+ ?up-cast (macro;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)))
+
+ _
+ (macro;fail (format "Cannot temporarily define casting functions ("
+ down-cast " & " up-cast
+ ") because definitions like that already exist.")))))
+
+(syntax: #hidden (un-install-casts)
+ (do Monad<Lux>
+ [this-module-name macro;current-module-name
+ ?down-cast (macro;find-macro [this-module-name down-cast])
+ ?up-cast (macro;find-macro [this-module-name up-cast])]
+ (case [?down-cast ?up-cast]
+ [(#;Some _) (#;Some _)]
+ (do @
+ [_ (un-install-casts' this-module-name)]
+ (wrap (list)))
+
+ _
+ (macro;fail (format "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 (::: wrap (list)))))
+
+(syntax: #export (model: [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 (L/map code;local-symbol type-vars)
+ model-declaration (` ((~ (code;local-symbol name)) (~@ type-varsC)))
+ representation-declaration (` ((~ hidden-name) (~@ type-varsC)))
+ conversion-functions (: (List Code)
+ (if (list;empty? type-vars)
+ (list)
+ (let [export' (case export
+ #;None #;None
+ (#;Some _) (#;Some #cs;Hidden))]
+ (list (` (def: (~@ (csw;export export'))
+ (~ (code;local-symbol (down-cast-name name)))
+ (All [(~@ type-varsC)]
+ (-> (~ representation-declaration) (~ model-declaration)))
+ (|>. :!!)))
+ (` (def: (~@ (csw;export export'))
+ (~ (code;local-symbol (up-cast-name name)))
+ (All [(~@ type-varsC)]
+ (-> (~ model-declaration) (~ representation-declaration)))
+ (|>. :!!)))))))]
+ (wrap (list& (` (type: (~@ (csw;export export)) (~ model-declaration)
+ (host (~ hidden-name))))
+ (` (type: (~@ (csw;export export)) (~ representation-declaration)
+ (~ representation-type)))
+ ($_ L/append
+ conversion-functions
+ (list (` (install-casts (~ (code;local-symbol name)) [(~@ type-varsC)])))
+ primitives
+ (list (` (un-install-casts))))))))