├── Clojure-translate.cabal ├── Clojure ├── AstTransform.hs ├── CodeGen.hs ├── DeSugar.hs ├── Syntax.hs └── Translate.hs ├── LICENSE ├── Main.hs ├── README ├── Setup.hs ├── backend.clj ├── docs ├── Clojure-CodeGen.html ├── Clojure-Syntax.html ├── Clojure-Translate.html ├── Main.html ├── Translator.html ├── doc-index.html ├── frames.html ├── haddock-util.js ├── haddock.css ├── haskell_icon.gif ├── index-frames.html ├── index.html ├── mini_Clojure-CodeGen.html ├── mini_Clojure-Syntax.html ├── mini_Clojure-Translate.html ├── mini_Main.html ├── mini_Translator.html ├── minus.gif └── plus.gif ├── makedocs ├── tests ├── add.hs ├── add.hs.clj ├── addtest.clj ├── compSimple.hs ├── compSimple.hs.clj ├── comprehensions.hs ├── comprehensions.hs.clj ├── curry_example.hs ├── curry_example.hs.clj ├── curryexample.clj ├── demo.hs ├── demo.hs.clj ├── dosimple.hs ├── dosimple.hs.clj ├── guardtest.hs ├── hanoi.hs ├── hanoi.hs.clj ├── hello.hs ├── lambda.hs ├── lambda.hs.clj ├── let.hs ├── let.hs.clj ├── lists.hs ├── lists.hs.clj ├── map.hs ├── map.hs.clj ├── myflip.hs ├── quicksort.hs ├── quicksort.hs.clj ├── simpleadd.hs ├── tupleadd.hs ├── tupleadd.hs.clj └── workingcurry.clj └── translator_presentation.odp /Clojure-translate.cabal: -------------------------------------------------------------------------------- 1 | Name: Clojure-translate 2 | Version: 0.0 3 | Description: Translate haskell into clojure 4 | License: GPL 5 | License-file: LICENSE 6 | Author: Daniel Mead 7 | Maintainer: d.w.mead@gmail.com 8 | Build-Type: Simple 9 | Cabal-Version: >=1.2 10 | 11 | Executable Clojure-Translate 12 | Main-is: Main.hs 13 | Build-Depends: base >= 3, haskell-src-exts >=1.10.2, uniplate >=1.6, base 14 | 15 | 16 | -------------------------------------------------------------------------------- /Clojure/AstTransform.hs: -------------------------------------------------------------------------------- 1 | module Clojure.AstTransform where 2 | 3 | import Clojure.Syntax as Sexp 4 | import Data.Data 5 | import Data.Typeable 6 | import Data.Generics.PlateData 7 | 8 | 9 | 10 | 11 | listIdents x = [y | (Atomic (Ident y)) <- universe x] 12 | 13 | listall x = [y | y <- universe x] 14 | 15 | replaceident a b = transform $ (\q -> case q of 16 | (Atomic (Ident i)) -> 17 | if (i == b) then (Atomic (Ident a)) 18 | else (Atomic (Ident i)) 19 | z -> z) 20 | 21 | 22 | 23 | replacenode b a = transform $ (\q -> if (q == b) then a 24 | else q) 25 | 26 | gensympairs = transform $ (\q -> case q of 27 | (Lambda (x:[]) y) -> (replacenode x (Genpair ((Gensym x), x)) (Lambda [x] y)) 28 | x -> x) 29 | 30 | 31 | unpackLambdas = transform $ (\q -> case q of 32 | (Lambda (x:[]) y) -> (Lambda [(Atomic (Ident "params"))] 33 | (BMatch (x,y))) 34 | x -> x) 35 | -------------------------------------------------------------------------------- /Clojure/CodeGen.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | The 'CodeGen' module provides the transformer from a clojure AST into executeable code 3 | 4 | class instances for Generateable of clojure ASTS are provided 5 | 6 | -} 7 | 8 | module Clojure.CodeGen where 9 | 10 | import Data.List 11 | 12 | 13 | import Clojure.Syntax 14 | 15 | 16 | 17 | {- | The 'Generateable' class is used for types representing clojure ASTS 18 | which we want to traxnsform into executable code 19 | 20 | Every dependant type of a clojure AST is generateable 21 | 22 | -} 23 | 24 | 25 | class Generateable a where 26 | gen :: a -> String 27 | 28 | instance Generateable Namespace where 29 | gen a = genNamespace a 30 | 31 | instance Generateable Sexp where 32 | gen x = gensexp x 0 33 | 34 | 35 | 36 | gparen x = "(" ++ x ++ ")" 37 | gbrackets x = "[" ++ x ++ "]" 38 | backquote x = "`" ++ x 39 | backtick x = "'" ++ x 40 | gnil = "()" 41 | space = " " 42 | --space = ++ . " ". ++ 43 | 44 | {- | 45 | 'genNamespace' converts the AST of a clojure namespace to executeable code 46 | 47 | for now, namespace constructs are ommited for simplicity 48 | 49 | -} 50 | 51 | genNamespace :: Namespace -> String 52 | genNamespace (Namespace name functions) = concat $ map (\x -> (gensexp x 0)) functions 53 | 54 | 55 | 56 | {- | 'gensexp' converts the AST of an S-expression into executable code 57 | 58 | 59 | Each special form for clojure needs it's own forms, so we'll generate the code accordingly 60 | 61 | -} 62 | 63 | fromPattern (Pat x) = x 64 | 65 | 66 | gensexp :: Sexp -> Int -> String 67 | gensexp Nil spaces = (indent spaces) ++ gnil 68 | gensexp WildCard spaces = "_" 69 | gensexp Cons spaces= "cons " 70 | gensexp (Atomic x) spaces = gen x 71 | gensexp (Func name bodies) spaces = genfunction name bodies spaces 72 | gensexp (List []) spaces = gnil 73 | gensexp (List x) spaces = 74 | gparen $ "list " ++ (foldr (\y -> (((gen y)++ " ") ++)) [] x) 75 | gensexp (Plist []) spaces = gnil 76 | gensexp (Plist x) spaces = 77 | gparen $ (foldr (\y -> (((gen y)++ " ") ++)) [] x) 78 | gensexp (Apply x y) spaces = gparen $ (gen x) ++ " " ++ (genParam y) 79 | gensexp (InfixApply x op z) spaces = 80 | gparen $ ((gensexp op spaces) ++ " " ++ 81 | (genParam x) ++ " " ++ (genParam z)) 82 | gensexp (PInfixApply x op z) spaces = 83 | gparen $ ((gensexp op spaces) ++ space ++ 84 | (gen x) ++ space ++ 85 | (gen z)) 86 | gensexp (Lambda params body) spaces = genLambda (Lambda params body) 87 | gensexp (IF x y z) spaces = gparen $ "if " ++ (gen x) ++ (gen y) ++(gen z) 88 | gensexp (BMatch (pat, body)) spaces = gencondpair [(BMatch (pat,body))] 0 89 | gensexp (Gensym x) y = "(gensym " ++ gen x ++ ")" 90 | gensexp x _ = error ("can't gen this: " ++ (show x)) 91 | 92 | 93 | --all 94 | 95 | genLambda (Lambda pat (BMatch (p1,body))) = 96 | "`(fn [~lparam]" ++ 97 | " (let [~lbinds (match `" ++ (gen (head pat)) ++ " ~lparam)] \n " ++ 98 | " (cond (matches ~lbinds) (eval (applyBinds ~lbinds " ++ (genBody body) ++ ")))))" 99 | genLambda (Lambda pat body) = 100 | "(fn [" ++ (gen (head pat)) ++ "]" ++ (gen body) ++ ")" 101 | 102 | 103 | -- gparen $ "fn " ++ "[" ++ (gen (head exp)) ++ "]" ++ (gen body) 104 | -- gparen $ "fn " ++ (gbrackets $ (concat (map gen exp))) ++ (gen body) 105 | 106 | genatoms :: [String] -> [Char] 107 | genatoms (x:xs) = gparen $ (foldr (\q -> ((q ++ " ") ++)) [] (x:xs)) 108 | genvector x = gbrackets $ genatoms x 109 | genLet vec body = gparen $ "let " ++ (genvector vec) ++ body 110 | 111 | 112 | genParam (Atomic (Ident x )) = x 113 | genParam (List []) = gnil 114 | genParam (Plist []) = gnil 115 | genParam (Plist x) = 116 | gparen $ (foldr (\y -> (((gen y)++ " ") ++)) [] x) 117 | genParam (List x) = 118 | gparen $ "list " ++ (foldr (\y -> (((genParam y)++ " ") ++)) [] x) 119 | genParam x = gen x 120 | 121 | 122 | genpair :: (Sexp, Sexp) -> String 123 | genpair (pattern, function) = 124 | "(match params " ++ (gen pattern) ++ " " ++ "\'"++(gen function) ++ " )" 125 | 126 | genbindpair :: [Sexp] -> Int -> String 127 | genbindpair [] num = " " 128 | genbindpair ((BMatch (pat,func)):xs) num = (replicate 4 ' ') ++ 129 | "b"++(show num)++ 130 | " (match `" ++(gen pat) ++ " params" ++")" ++ "\n" 131 | ++ (genbindpair xs (num+1)) 132 | 133 | genbindpair x num = "Couldn't generate " ++ show x 134 | 135 | 136 | 137 | genBody (Atomic (Ident x)) = x 138 | genBody (Lambda pat (BMatch (p1,body))) = 139 | "`(fn [~lparam]" ++ 140 | " (let [~lbinds (match `" ++ (gen (head pat)) ++ " ~lparam)] \n " ++ 141 | " (cond (matches ~lbinds) (eval (applyBinds ~lbinds " ++ (genBody body) ++ ")))))" 142 | 143 | genBody x = "`" ++ gen x 144 | 145 | {- 146 | genBodytoplevel (Lambda pat (BMatch (p1, body))) = 147 | "`(fn [~lparam] \n" ++ 148 | " (let [~lbinds (match `" ++ (gen (head pat)) ++ " ~lparam)] \n " ++ 149 | " (cond (matches ~lbinds) (eval (applyBinds ~lbinds " ++ (genBody body) ++ ")))))" 150 | genBodytoplevel x = (genBody x) 151 | -} 152 | genStmt (Gen e1 e2) = "(" ++ (gen e1) ++ " <- " ++ (gen e2) ++ ")" 153 | genStmt (Qualifier e) = gen e 154 | 155 | --(> (count bindings0) 0) 156 | gencondpair :: [Sexp] -> Int -> String 157 | gencondpair [] num = " " 158 | gencondpair ((BMatch (_ ,Lambda pat body)):morepairs) num = 159 | " (matches b"++(show num)++ ") (eval (applyBinds b"++(show num)++ " "++ 160 | (genBody (Lambda pat body)) ++ ")) \n" ++ 161 | (gencondpair morepairs (num+1)) 162 | gencondpair ((BMatch (pat,func)):xs) num = " (matches b"++(show num)++ " ) (eval (applyBinds b"++(show num) ++ " " ++ (genBody func) ++ ")) \n" ++ (gencondpair xs (num+1)) 163 | 164 | gencondpair x num= "Coulldn't gen " ++ (show x) ++ " in gencondpair \n" 165 | 166 | 167 | 168 | 169 | genfunction :: Sexp -> [Sexp] -> Int -> String 170 | genfunction name pairs indent = 171 | let bindings = (genbindpair pairs 0) 172 | matches = gencondpair pairs 0 173 | in "(defn " ++ (gen name) ++ "[params]" ++ "\n" ++ 174 | " (let [ \n" ++ bindings ++ 175 | " lparam (gensym \"l\") \n" ++ 176 | " lbinds (gensym \"b1\") ]\n" ++ 177 | " (cond \n" ++ matches ++ "\n true (list :patternmatchfail " 178 | ++ (gen name) ++ " params) )))\n\n\n" 179 | 180 | {- | 'genfunction' does the code generation for a function definition form. 181 | 182 | IE 183 | 184 | >(defn name args 185 | > (body)) 186 | 187 | 188 | or, if the source haskell had multiple patterns 189 | 190 | 191 | > (defn name args 192 | > (cond (match args pat body) 193 | > (match args pat body) 194 | > (match args pat body) ) 195 | 196 | -} 197 | 198 | instance Generateable Atom where 199 | gen x = genatom x 200 | 201 | 202 | --instance Generateaboe Pattern where 203 | -- gen x 204 | {- | 'genatom' generates the the code for non list items in an s-expression 205 | 206 | 207 | as in the list 208 | 209 | > ((1 2 3) 1 2.0 4 fifty nil) 210 | 211 | the atomic parts are 1,2,3 1, 2.0, 4 and fifty 212 | 213 | 214 | -} 215 | 216 | 217 | genatom :: Atom -> String 218 | genatom (Lit x) = (show x) 219 | genatom (Int x) = (show x) 220 | genatom (String x) = x 221 | genatom (Ident x) = x 222 | genatom (Var x) = x 223 | genatom (Symbol x) = x 224 | 225 | 226 | {- | 227 | 'indent' indents a line some spaces 228 | 229 | -} 230 | 231 | indent x = replicate x ' ' 232 | -------------------------------------------------------------------------------- /Clojure/DeSugar.hs: -------------------------------------------------------------------------------- 1 | module Clojure.DeSugar where 2 | 3 | import Language.Haskell.Exts.Syntax as HS 4 | 5 | 6 | 7 | --deSugar (Listcomp exp (q:qs)) = 8 | 9 | 10 | --rule (a) page 132 11 | 12 | deSugar (HS.ListComp exp ((QualStmt (Generator _ gpat gexp)):qs)) 13 | = (App 14 | (Var (UnQual (Ident "flatmap"))) 15 | (Tuple [(Lambda (SrcLoc "" 0 0) [gpat] 16 | (deSugar (ListComp exp qs))), gexp]) 17 | ) 18 | 19 | --rule (b) 20 | deSugar (ListComp exp ((QualStmt (Qualifier guard)): qs)) = 21 | If (deSugar guard) 22 | (deSugar (ListComp exp qs)) 23 | (List []) 24 | 25 | 26 | --rule (c) 27 | --deSugar (ListComp exp []) = (App (App (Var (Special Cons)) exp) (List [])) 28 | deSugar (ListComp exp []) = (InfixApp exp (QConOp (Special Cons)) (List [])) 29 | 30 | 31 | 32 | 33 | --deSugar 34 | 35 | 36 | 37 | 38 | deSugar x = x 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | -------------------------------------------------------------------------------- /Clojure/Syntax.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | The 'Syntax' module provides an AST in types of (a subset of) clojure 3 | 4 | These types express the structure of s-expressions while having special forms for 5 | things like function defintition, patterns, pattern matching and different types of list atoms. 6 | 7 | -} 8 | {-# OPTIONS_GHC -XDeriveDataTypeable #-} 9 | module Clojure.Syntax where 10 | 11 | 12 | 13 | import Data.Data 14 | import Data.Typeable 15 | import Data.Generics.PlateData 16 | 17 | 18 | {- | a container for clojure namespaces. 19 | for now, this is just a name with a list of S-expressions 20 | -} 21 | data Namespace = Namespace String [Sexp] 22 | deriving (Show, Eq) 23 | 24 | 25 | fromNamespace (Namespace name funcs) = funcs 26 | 27 | 28 | {- | 29 | Pattern is a container for pattern lists 30 | -} 31 | data Pattern = Pat [Sexp] 32 | | Ptrue 33 | -- ^ a catch-call form for patterns 34 | deriving (Show, Eq) 35 | 36 | {- | 37 | Atom is a type for list contents that have a primative type 38 | -} 39 | 40 | data Stmt = Gen Sexp Sexp 41 | | Qualifier Sexp 42 | | LetStmt Binds 43 | deriving (Eq, Show, Data, Typeable) 44 | 45 | 46 | data Atom = Lit Char 47 | -- ^ a literal character inside an S-exp 48 | | String String 49 | -- ^ A Primative String 50 | | Ident String 51 | -- ^ Idenitifer For Named Functions And Data structures 52 | | Var String 53 | -- ^ identifier for variables 54 | | Symbol String 55 | | Int Integer 56 | -- ^ a single character used for operators 57 | deriving (Eq, Show, Data, Typeable) 58 | 59 | 60 | {- | 61 | Sexp is the primary representation for S-expressions 62 | Normally, an S-expression is a s 63 | -} 64 | data Sexp = Atomic Atom 65 | | WildCard 66 | | Void 67 | | Cons 68 | | Lambda [Sexp] Sexp 69 | -- ^ cons with it's element as a general sexp 70 | | IF Sexp Sexp Sexp 71 | -- ^ if expr then expr else expr (conditionals) 72 | | Apply Sexp Sexp 73 | -- ^ a general form for function application 74 | | InfixApply Sexp Sexp Sexp 75 | | PInfixApply Sexp Sexp Sexp 76 | -- ^ a general form for infix function calls 77 | | BMatch (Sexp, Sexp) 78 | | Func Sexp [Sexp] 79 | -- ^function def and it's pattern cases 80 | | List [Sexp] 81 | -- ^ regular s-expression list 82 | | Gensym Sexp 83 | | Tuple [Sexp] 84 | | Ptuple [Sexp] 85 | | Plist [Sexp] 86 | | ListComp Sexp [Stmt] 87 | | Nil 88 | | Let Binds Sexp 89 | | Do [Sexp] 90 | | Genpair (Sexp, Sexp) 91 | deriving (Show, Eq, Data, Typeable) 92 | 93 | 94 | --instance Uniplate Sexp 95 | --instance Uniplate Atom 96 | --instance Uniplate Namespace 97 | 98 | 99 | data Binds = Binds [(Sexp, Sexp)] 100 | deriving (Show, Eq, Data, Typeable) 101 | 102 | 103 | listIdents x = [y | (Atomic (Ident y)) <- universe x] 104 | 105 | 106 | 107 | 108 | replaceIdent a b = transform $ (\q -> case q of 109 | (Atomic (Ident i)) -> 110 | if (i == b) then (Atomic (Ident a)) 111 | else (Atomic (Ident i)) 112 | z -> z) 113 | 114 | 115 | 116 | -------------------------------------------------------------------------------- /Clojure/Translate.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | The 'Translate' module implements a transformational grammer 3 | that converts an AST for haskell into one for clojure 4 | 5 | This module uses the haskell-src-ext AST to represent haskell. 6 | It transforms those types into the clojure representation 7 | found in Clojure.Sytnax 8 | 9 | -} 10 | 11 | 12 | module Clojure.Translate where 13 | 14 | import Language.Haskell.Exts.Syntax as HS 15 | import Clojure.Syntax as Sexp 16 | import Clojure.DeSugar as DS 17 | import Clojure.AstTransform 18 | 19 | class Translateable a where 20 | translate :: a -> Namespace 21 | 22 | 23 | instance Translateable Module where 24 | translate a = translateModule a 25 | 26 | 27 | --bind (Gen e1 e2) rhs = Let (Binds [(e1, e2)]) (bind rhs) 28 | --bind (Qualifier exp) rhs = Do exp exp 29 | --bind (LetStmt (Binds [(e1,e2)])) = 30 | 31 | 32 | 33 | {- | 'translateModule' translates a haskell module into a clojure namespace. 34 | a module usually contains information about imports/exports and compiler directives 35 | as well as a list of declarations. For now, we're just preseving the name along with declarations. 36 | -} 37 | 38 | modstring (ModuleName x) = x 39 | translateModule :: Module -> Namespace 40 | translateModule (Module _ modname _ _ _ _ decl) = 41 | Namespace (modstring modname) ( map (translateDecl) decl) 42 | 43 | 44 | {- | 'translateDecl' translates a declaration found under a haskell module to a clojure 45 | S-expression. this could be almost anything listed in the haskell spec, but is just function 46 | bindings for now. 47 | -} 48 | 49 | 50 | matchname (Match _ name _ _ _ _ ) = name 51 | 52 | 53 | 54 | translateDecl :: Decl -> Sexp 55 | translateDecl (FunBind matches) = 56 | let funcname = translateName . matchname . head $ matches 57 | in Func funcname (map (translateMatch False ) matches) 58 | -- in unpackLambdas $ Func funcname (map (translateMatch False ) matches) 59 | 60 | {- 61 | translateDecl (PatBind srcloc pat (Maybe atype) rhs binds) = 62 | let funcname = translateName . matchname . head $ matches 63 | in 64 | -} 65 | 66 | {- | 67 | 'translateQName' translates qualified names into a list atom 68 | -} 69 | 70 | translateQName :: QName -> Sexp 71 | translateQName (UnQual x) = translateName x 72 | translateQName (Special x) = translateSpecial x 73 | 74 | 75 | translateSpecial :: SpecialCon -> Sexp 76 | translateSpecial HS.Cons = Sexp.Cons 77 | 78 | 79 | {- | 80 | 'translateQOP' translates qualified and unqualified operators into S-expressions 81 | -} 82 | 83 | 84 | 85 | --translate bindings declarations, as opposed to top level ones which have different syntax 86 | translateBDecl (PatBind _ pat _ (UnGuardedRhs exp) binds) = (translatePattern pat, translateExp exp) 87 | 88 | 89 | translateBinds (BDecls decls) = Sexp.Binds $ map translateBDecl decls 90 | 91 | 92 | --translateStmt :: HS.Stmt -> Sexp.Stmt 93 | translateStmt (HS.Generator _ pat exp) = Sexp.Gen (translatePattern pat) (translateExp exp) 94 | translateStmt (HS.Qualifier exp) = Sexp.Qualifier (translateExp exp) 95 | translateStmt (HS.LetStmt binds) = Sexp.LetStmt (translateBinds binds) 96 | 97 | translateQualStmt (QualStmt stmt) = translateStmt stmt 98 | 99 | translateQOP :: QOp -> Sexp 100 | translateQOP (QVarOp x) = translateQName x 101 | translateQOP (QConOp x) = translateQName x 102 | 103 | 104 | {- | 105 | 'translateExp' translates haskell expressions into equivilent S-expressions 106 | -} 107 | 108 | translateExp :: Exp -> Sexp 109 | translateExp (Con x ) = translateQName x 110 | translateExp (HS.Var x ) = translateQName x 111 | translateExp (HS.Lit x) = translateLiteral x 112 | translateExp (HS.InfixApp a sym b) = InfixApply (translateExp a) (translateQOP sym) (translateExp b) 113 | translateExp (App x y) = Apply (translateExp x) (translateExp y) 114 | --translateExp (HS.List []) = Sexp.Nilc 115 | translateExp (HS.List x) = Sexp.List (map translateExp x) 116 | translateExp (HS.Tuple x) = Sexp.List (map translateExp x) 117 | translateExp (Paren x) = translateExp x 118 | translateExp (HS.If x y z ) = Sexp.IF (translateExp x) (translateExp y) (translateExp z) 119 | translateExp (HS.Lambda loc pats exp) = 120 | if (length pats == 1) then 121 | Sexp.Lambda (map (translatePattern) pats) (translateExp exp) 122 | else 123 | Sexp.Lambda [translatePattern (head pats)] (translateExp (HS.Lambda loc (tail pats) exp)) 124 | 125 | translateExp (HS.ListComp exp stmts) = translateExp $ DS.deSugar $ (HS.ListComp exp stmts) 126 | 127 | 128 | 129 | 130 | {- | 'translateMatch' translates a match section of a function declaration 131 | into a clojure function definition 132 | -} 133 | 134 | --translateMatch :: Match -> Sexp 135 | --translateMatch curried (Match _ name (p1:[]) _ (UnGuardedRhs rhs) binds) = 136 | -- (BMatch (translatePattern p1, translateExp rhs)) 137 | 138 | translateMatch curried (Match _ name (p1:[]) _ (UnGuardedRhs rhs) binds) = 139 | if (curried == True) 140 | then Sexp.Lambda [translatePattern p1] 141 | (BMatch (translatePattern p1, translateExp rhs)) 142 | else (BMatch (translatePattern p1, translateExp rhs)) 143 | 144 | translateMatch curried (Match _ name (p1:pats) _ (UnGuardedRhs rhs) binds) 145 | = if (curried == True) 146 | then Sexp.Lambda [translatePattern p1] 147 | (BMatch (translatePattern p1, 148 | (translateMatch True (Match (SrcLoc "" 0 0) name (pats) Nothing (UnGuardedRhs rhs) binds)))) 149 | else 150 | (BMatch 151 | (translatePattern p1, 152 | (translateMatch True (Match (SrcLoc "" 0 0) name (pats) Nothing (UnGuardedRhs rhs) binds)))) 153 | 154 | 155 | 156 | 157 | 158 | {- | 'translateLiteral' converts a haskell literal into an s-expression atom 159 | 160 | -} 161 | --translateLiteral:: Literal -> Atom 162 | translateLiteral (HS.Char x) = Atomic (Sexp.Lit x) 163 | translateLiteral (HS.Int x) = Atomic (Sexp.Int x) 164 | 165 | --translateName :: Name -> Atom 166 | translateName (HS.Ident x) = Atomic $ Sexp.Ident x 167 | translateName (HS.Symbol x) = Atomic $ Sexp.Symbol x 168 | 169 | 170 | 171 | 172 | translatePattern (PVar x) = translateName x 173 | translatePattern (PInfixApp e1 op e2) = PInfixApply (translatePattern e1) (translateQName op) (translatePattern e2) 174 | translatePattern (PParen x) = translatePattern x 175 | --translatePattern (PList []) = Nil 176 | translatePattern (PList x) = Sexp.Plist (map (translatePattern) x) 177 | translatePattern (HS.PTuple x) = Sexp.Plist (map translatePattern x) 178 | translatePattern (HS.PWildCard) = WildCard 179 | translatePattern (PLit x) = translateLiteral x -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011 Daniel Mead (d.w.mead@gmail.com) 2 | 3 | This program is free software: you can redistribute it and/or modify 4 | under the terms of the GNU General Public License as published by 5 | the Free Software Foundation, either version 3 of the License, or 6 | (at your option) any later version. 7 | 8 | This program is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | GNU General Public License for more details. 12 | 13 | You should have received a copy of the GNU General Public License 14 | along with this program. If not, see . 15 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: 'Translator' 3 | 4 | The top level for haskell to clojure translation. 5 | 6 | This will: 7 | 8 | -Provide functionality to inspecting haskell ASTs via the haskell-src-exts package 9 | 10 | -Use the translform rules from Clojure.Translate to translate a Haskell AST to a clojure equivilant 11 | into the clojure AST in Clojure.Syntax 12 | 13 | -call the code generator in Clojure.CodeGen and write the results to a file 14 | -} 15 | {-# OPTIONS_GHC -XDeriveDataTypeable #-} 16 | module Main where 17 | 18 | 19 | 20 | import Language.Haskell.Exts as HS 21 | import Clojure.Syntax as CS 22 | import Clojure.Translate 23 | import Clojure.CodeGen 24 | import Clojure.AstTransform 25 | import System.IO.Unsafe 26 | import System.IO 27 | import System.Environment 28 | import Data.Generics.Uniplate 29 | 30 | {- | 31 | 'astfromFile' calls the parser from 32 | 33 | -} 34 | 35 | 36 | 37 | --cgetvars x = [y | (.Var y) <- universe x] 38 | 39 | 40 | 41 | gethaskellast x = fromParseResult $ unsafePerformIO $ parseFile x 42 | getclojureast x = translate $ fromParseResult $ unsafePerformIO $ parseFile x 43 | 44 | 45 | printastSrc x = 46 | do y <- return $ fromParseResult $ unsafePerformIO $ parseFile x 47 | putStr $ prettyPrint y ++ "\n" 48 | return () 49 | 50 | translateFile x = 51 | do putStr $ "translating file: " ++ x ++ "\n" 52 | haskellAST <- return $ gethaskellast x 53 | --print haskellAST 54 | clojureAST <- return $ translate haskellAST 55 | --print clojureAST 56 | outfile <- openFile (x++".clj") WriteMode 57 | hPutStr outfile (gen clojureAST) 58 | hClose outfile 59 | return () 60 | 61 | 62 | testpath = "/home/" 63 | 64 | 65 | test = "tests/lists.hs" 66 | test1 = "tests/add.hs" 67 | --test2 = "tests/hello.hs" 68 | test2 = "tests/map.hs" 69 | test3 = "tests/tupleadd.hs" 70 | test4 = "tests/hanoi.hs" 71 | test5 = "tests/quicksort.hs" 72 | test6 = "tests/lambda.hs" 73 | test7 = "tests/comprehensions.hs" 74 | test8 = "tests/compSimple.hs" 75 | --test9 = "tests/let.hs" 76 | --test10 = "tests/dosimple.hs" 77 | test11 = "tests/curry_example.hs" 78 | test12 = "tests/demo.hs" 79 | 80 | tests = [test,test1,test2,test3,test4,test5,test6,test7,test8,{-test9,test10,-}test11,test12] 81 | 82 | runall = mapM_ translateFile tests 83 | 84 | 85 | 86 | main = do args <- System.Environment.getArgs 87 | translateFile (head args) 88 | return () 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dmead/Clojure-translate/10b17011a0b6dc826e7d4ce203092b3dfc257b18/README -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /backend.clj: -------------------------------------------------------------------------------- 1 | (declare applyBinds) 2 | 3 | (def matchfail :matchfail) 4 | (declare matches) 5 | (defn third [x] 6 | (first (rest (rest x)))) 7 | 8 | (defmacro consp [x] 9 | `(or (and (seq? ~x) (= (first ~x) `cons)) 10 | (= (first ~x) 'cons))) 11 | 12 | (defn conselem [x] 13 | (second x)) 14 | 15 | (defn conslist [x] 16 | (third x)) 17 | 18 | 19 | (defn singletonp [x] 20 | (and (list? x) (= (count x) 1) (symbol? (first x)))) 21 | 22 | (defn listp [x] 23 | (= (first x) 'list)) 24 | 25 | (defn nilp [x] 26 | (= () x)) 27 | 28 | (defn atomp[x] 29 | (not (seq? x))) 30 | 31 | 32 | (declare match) 33 | 34 | (defn zip-aux [x y acc] 35 | (cond (empty? x) acc 36 | true (recur (rest x) (rest y) (concat acc (list (list (first x) (first y)) ))))) 37 | 38 | (defn zip [x y] 39 | (zip-aux x y ())) 40 | 41 | (defn makebind [pat value] 42 | (cond (= pat value) '() 43 | (or (seq? value) (list? value)) (seq (list pat (cons 'list value))) 44 | true (seq (list pat value)))) 45 | 46 | (defn zipmatch [pat state] 47 | (cond (and (empty? state) (empty pat)) '() 48 | true (concat (match (first pat) (first state)) (match (rest 49 | pat) (rest state))))) 50 | 51 | 52 | (defmacro mzipmatch [pat state] 53 | (cond (and (empty? state) (empty pat)) '() 54 | true `( ~(first pat) ~(first state) (mzipmatch ~(rest pat) ~(rest state))))) 55 | 56 | (defmacro mcount[x] 57 | (count x)) 58 | 59 | (defn matchlist [pat state] 60 | (cond (atomp state) (list (list :matchfail :matchlistfail)) ;;needseqable from contrib 61 | (= (count state) (count pat)) (zipmatch pat state) 62 | true (list (list :matchfail :matchlistfail)))) 63 | 64 | (defn matchcons [pat state] 65 | (or (seq? state) (seq? state)) 66 | (cond (empty? state) (seq (list :matchfail :emptylistwithcons)) 67 | true (cons (makebind (conselem pat) (first state)) 68 | (match (conslist pat) (rest state))) 69 | true (list (list :matchfail :matchconsfail)))) 70 | 71 | (defmacro msecond [[x y z]] 72 | y) 73 | 74 | 75 | (defmacro mmatchcons [pat state] 76 | (or (seq? state) (seq? state)) 77 | (cond (empty? state) `(seq (list :matchfail :emptylistwithcons)) 78 | true `(cons (~(`(eval (msecond ~pat))))(~(first state)) 79 | (match (conslist pat) (rest state))) 80 | true `(list (list :matchfail :matchconsfail)))) 81 | 82 | 83 | 84 | (defn matchsymbol [pat state] 85 | (cond (symbol? state) (list (list pat state)) 86 | (= pat '_) '() 87 | (= pat state) '() 88 | true (list (makebind pat state)))) 89 | 90 | 91 | (defn matchnumber [pat state] 92 | (cond (= pat state) '() 93 | true (seq (list (list :matchfail :matchnumberfail))))) 94 | 95 | 96 | (declare genp) 97 | 98 | (defn matchgen [pat state] 99 | (cond (and (genp pat) (genp state)) 100 | (cons (makebind (first pat) (first state)) (match (third pat) (third state))))) 101 | 102 | 103 | (defn matchempty[state] 104 | (cond (empty? state) () 105 | true (list :matchfail))) 106 | 107 | 108 | (defn match [pat state] 109 | (cond 110 | (symbol? pat) 111 | (matchsymbol pat state) 112 | (empty? pat) 113 | (matchempty state) 114 | (number? pat) 115 | (matchnumber pat state) 116 | (consp pat) 117 | (matchcons pat state) 118 | (seq? pat) 119 | (matchlist pat state) 120 | (and (empty? state) (empty? pat)) 121 | '() 122 | true (list :matchfail) 123 | )) 124 | 125 | 126 | (defn domatch [pat state] 127 | (vec (reduce concat (match pat state)))) 128 | 129 | (declare member) 130 | 131 | (defn PM [pat state] 132 | (matches (match pat state))) 133 | 134 | (defn matches [binds] 135 | (not (member :matchfail binds))) 136 | 137 | (defn member [item col] 138 | (cond (empty? col) false 139 | (= item (first col)) true 140 | true (recur item (rest col)))) 141 | 142 | (def ++ concat) 143 | 144 | (defmacro rewrite [binds expr] 145 | (let [evaluated-binds (eval binds)] 146 | `(let ~evaluated-binds ~expr))) 147 | 148 | 149 | (use 'clojure.stacktrace) 150 | 151 | (defn st [] 152 | (print-stack-trace (root-cause *e) 100)) 153 | 154 | 155 | (defn z[L] 156 | (let [ foo '(list 1 2)] 157 | (eval `(concat ~foo '~L)))) 158 | 159 | (defn add[x y] 160 | (+ x y)) 161 | 162 | (defn papply[func p1] 163 | (fn [p2] (func p1 p2))) 164 | 165 | (defn succ[x] 166 | (+ x 1)) 167 | 168 | (defn enumfromlazy[params] 169 | (let [ 170 | b2 (domatch '(current end) params) 171 | ] 172 | (cond (matches b2) 173 | (eval (applyBinds b2 174 | '(if (= current end) (list end) 175 | (cons current 176 | (enumfromlazy (list (succ current) end))))))))) 177 | 178 | 179 | 180 | (defn enumtolazy [end] 181 | (enumfromlazy (list 1 end))) 182 | 183 | (defn enumfrom[current end] 184 | (if (= current end) (list end) 185 | (cons current (enumfrom (succ current) end)))) 186 | 187 | 188 | (defn matchfilter [pat list] 189 | (let [b0 (domatch pat (first list))] 190 | (cond 191 | (empty? list) '() 192 | (matches b0) (cons (first list) (matchfilter pat (rest list)))))) 193 | 194 | 195 | (defn enumto[end] 196 | (enumfrom 1 end)) 197 | 198 | 199 | 200 | (def genpat '(x <- y)) 201 | 202 | (def genempty '(x <- ())) 203 | 204 | (defn genhead [x] 205 | (cond (genp x) (first (third x)) 206 | true '())) 207 | 208 | (defn genpat [x] 209 | (first x)) 210 | 211 | (defn decgen [x] 212 | (list (first x) (second x) (rest (eval (third x))))) 213 | 214 | 215 | (defn rewritePat[pat target val] 216 | (let [binds [target val] ] 217 | (eval `(applyBinds ~@binds ~pat)))) 218 | 219 | 220 | (defn emptyGen[x] 221 | (or (empty? (third x)) (not (seq (third x))))) 222 | 223 | 224 | (defn genp [x] 225 | (and (= (count x) 3) (= (second x) `<-))) 226 | (declare applyBinds) 227 | 228 | 229 | (defn bindsfromGen[x] 230 | (let [pat (first x) 231 | source (third x) 232 | binds (match pat (first source)) 233 | ] 234 | (cond (matches binds) binds 235 | true '()))) 236 | 237 | (defn consume [gen] 238 | (let [pat (first gen) 239 | expr (third gen) 240 | ] 241 | (cond (fn? (eval (first expr))) (list (list pat (first (eval `~expr))) (list pat `<- (rest (eval `~expr)))) 242 | (seq? expr) (list (list pat (first expr)) (list pat `<- (rest expr))) 243 | true (list :consumer :fail)))) 244 | 245 | 246 | (defn applyBind [bind expr] 247 | (cond (seq? expr) (map (fn [x] (cond (= x (first bind)) (second bind) 248 | (seq? x) (applyBind bind x) 249 | true x)) expr) 250 | (= (first bind) expr) (second bind))) 251 | 252 | 253 | (defn applyBinds [binds expr] 254 | (cond (empty? binds) expr 255 | true (applyBinds (rest binds) (applyBind (first binds) expr)))) 256 | 257 | 258 | 259 | 260 | 261 | (defmacro letbinds [binds expr] 262 | `(let [ ~@binds ] ~expr)) 263 | 264 | 265 | (defn flatbinds [x] 266 | (cond (empty? x) `() 267 | true (concat (first x) (flatbinds (rest x))))) 268 | 269 | 270 | 271 | (defn third [x] 272 | (first (next (next x)))) 273 | 274 | 275 | (defmacro msecond [x y z] 276 | `'~y) 277 | 278 | 279 | (defmacro isgen [x] 280 | (= (eval `(msecond ~@x)) '<-)) 281 | 282 | 283 | 284 | 285 | 286 | 287 | (defmacro mlist? [x] 288 | (eval `(list? '~x))) 289 | 290 | (defmacro listcomp [[exp & quals] res] 291 | (if (empty? quals) `(cons ~exp ~res) 292 | (let [ 293 | q1 (first quals) 294 | q (rest quals) 295 | ] 296 | (if (not (eval `(isgen ~q1))) 297 | `(if ~q1 (listcomp (~exp ~@q) ~res) ~res) 298 | (let [v (first q1) 299 | l1 (third q1) 300 | h (gensym "H-") 301 | us (gensym "US-") 302 | us1 (gensym "US1-") 303 | ] 304 | `(letfn [(~h [ ~us ] 305 | (if (empty? ~us) ~res 306 | (let [ 307 | ~v (first ~us) 308 | ~us1 (rest ~us) 309 | ] 310 | (listcomp (~exp ~@q) (~h ~us1))))) 311 | ] 312 | (~h ~l1))))))) 313 | 314 | 315 | 316 | 317 | (defn flatmap [params] 318 | (let [b0 (match `(f ()) params) 319 | b1 (match `(f (cons x xs)) params) 320 | ] 321 | (cond (matches b0) (eval (applyBinds b0 `())) 322 | (matches b1) (eval (applyBinds b1 `(++ (f x) (flatmap (list f xs)))))))) 323 | 324 | 325 | 326 | 327 | 328 | 329 | 330 | 331 | 332 | 333 | 334 | 335 | 336 | 337 | -------------------------------------------------------------------------------- /docs/Clojure-CodeGen.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Clojure.CodeGen
ContentsIndex
Clojure.CodeGen
Description

The CodeGen module provides the transformer from a clojure AST into executeable code 61 |

class instances for Generateable of clojure ASTS are provided 64 |

Synopsis
class Generateable a where
gen :: a -> String
genNamespace :: Namespace -> String
gensexp :: Sexp -> Int -> String
genpair :: (Sexp, Sexp) -> String
genbindpair :: [(Sexp, Sexp)] -> Int -> String
gencondpair :: [(Sexp, Sexp)] -> Int -> String
genfunction :: Sexp -> [(Sexp, Sexp)] -> Int -> String
genatom :: Atom -> String
Documentation
class Generateable a where

The Generateable class is used for types representing clojure ASTS 238 | which we want to traxnsform into executable code 239 |

Every dependant type of a clojure AST is generateable 242 |

Methods
gen :: a -> String
show/hide Instances
genNamespace :: Namespace -> String

genNamespace converts the AST of a clojure namespace to executeable code 337 |

for now, namespace constructs are ommited for simplicity 340 |

gensexp :: Sexp -> Int -> String

gensexp converts the AST of an S-expression into executable code 367 |

Each special form for clojure needs it's own forms, so we'll generate the code accordingly 370 |

genpair :: (Sexp, Sexp) -> String
genbindpair :: [(Sexp, Sexp)] -> Int -> String
gencondpair :: [(Sexp, Sexp)] -> Int -> String
genfunction :: Sexp -> [(Sexp, Sexp)] -> Int -> String
genatom :: Atom -> String

genatom generates the the code for non list items in an s-expression 471 |

as in the list 474 | 

 ((1 2 3) 1 2.0 4 fifty nil)
477 |

the atomic parts are 1,2,3 1, 2.0, 4 and fifty 480 |

Produced by Haddock version 2.4.2
497 | -------------------------------------------------------------------------------- /docs/Clojure-Syntax.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Clojure.Syntax
ContentsIndex
Clojure.Syntax
Description

The Syntax module provides an AST in types of (a subset of) clojure 61 |

These types express the structure of s-expressions while having special forms for 64 | things like function defintition, patterns, pattern matching and different types of list atoms. 65 |

Synopsis
data Namespace = Namespace String [Sexp]
data Pattern
= Pat [Sexp]
| Ptrue
data Stmt
= Gen Sexp Sexp
| Qualifier Sexp
| LetStmt Binds
data Atom
= Lit Char
| String String
| Ident String
| Var String
| Symbol String
| Int Integer
data Sexp
= Atomic Atom
| WildCard
| Void
| Cons
| Lambda Sexp Sexp
| IF Sexp Sexp Sexp
| Apply Sexp Sexp
| InfixApply Sexp Sexp Sexp
| PInfixApply Sexp Sexp Sexp
| Func Sexp [(Sexp, Sexp)]
| List [Sexp]
| Tuple [Sexp]
| Ptuple [Sexp]
| Plist [Sexp]
| ListComp Sexp [Stmt]
| Nil
| Let Binds Sexp
| Do [Sexp]
data Binds = Binds [(Sexp, Sexp)]
Documentation
data Namespace
a container for clojure namespaces. 478 | for now, this is just a name with a list of S-expressions 479 |
Constructors
Namespace String [Sexp]
show/hide Instances
data Pattern
Pattern is a container for pattern lists 563 |
Constructors
Pat [Sexp]
Ptruea catch-call form for patterns 597 |
show/hide Instances
data Stmt
Atom is a type for list contents that have a primative type 652 |
Constructors
Gen Sexp Sexp
Qualifier Sexp
LetStmt Binds
show/hide Instances
Eq Stmt
Show Stmt
data Atom
Constructors
Lit Chara literal character inside an S-exp 773 |
String StringA Primative String 786 |
Ident StringIdenitifer For Named Functions And Data structures 799 |
Var Stringidentifier for variables 812 |
Symbol String
Int Integera single character used for operators 837 |
show/hide Instances
data Sexp
Sexp is the primary representation for S-expressions 900 | Normally, an S-expression is a s 901 |
Constructors
Atomic Atom
WildCard
Void
Cons
Lambda Sexp Sexpcons with it's element as a general sexp 975 |
IF Sexp Sexp Sexpif expr then expr else expr (conditionals) 994 |
Apply Sexp Sexpa general form for function application 1011 |
InfixApply Sexp Sexp Sexp
PInfixApply Sexp Sexp Sexpa general form for infix function calls 1048 |
Func Sexp [(Sexp, Sexp)]function def and it's pattern cases 1067 |
List [Sexp]regular s-expression list 1082 |
Tuple [Sexp]
Ptuple [Sexp]
Plist [Sexp]
ListComp Sexp [Stmt]
Nil
Let Binds Sexp
Do [Sexp]
show/hide Instances
data Binds
Constructors
Binds [(Sexp, Sexp)]
show/hide Instances
Eq Binds
Show Binds
Produced by Haddock version 2.4.2
1310 | -------------------------------------------------------------------------------- /docs/Clojure-Translate.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Clojure.Translate
ContentsIndex
Clojure.Translate
Description

The Translate module implements a transformational grammer 61 | that converts an AST for haskell into one for clojure 62 |

This module uses the haskell-src-ext AST to represent haskell. 65 | It transforms those types into the clojure representation 66 | found in Clojure.Sytnax 67 |

Synopsis
class Translateable a where
translate :: a -> Namespace
translateModule :: Module -> Namespace
translateDecl :: Decl -> Sexp
translateQName :: QName -> Sexp
translateSpecial :: SpecialCon -> Sexp
translateQOP :: QOp -> Sexp
translateExp :: Exp -> Sexp
translateMatch :: Match -> (Sexp, Sexp)
Documentation
class Translateable a where
Methods
translate :: a -> Namespace
show/hide Instances
translateModule :: Module -> Namespace
translateModule translates a haskell module into a clojure namespace. 302 | a module usually contains information about imports/exports and compiler directives 303 | as well as a list of declarations. For now, we're just preseving the name along with declarations. 304 |
translateDecl :: Decl -> Sexp
translateDecl translates a declaration found under a haskell module to a clojure 329 | S-expression. this could be almost anything listed in the haskell spec, but is just function 330 | bindings for now. 331 |
translateQName :: QName -> Sexp
translateQName translates qualified names into a list atom 356 |
translateSpecial :: SpecialCon -> Sexp
translateQOP :: QOp -> Sexp
translateQOP translates qualified and unqualified operators into S-expressions 397 |
translateExp :: Exp -> Sexp
translateExp translates haskell expressions into equivilent S-expressions 422 |
translateMatch :: Match -> (Sexp, Sexp)
translateMatch translates a match section of a function declaration 449 | into a clojure function definition 450 |
Produced by Haddock version 2.4.2
466 | -------------------------------------------------------------------------------- /docs/Main.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Main
ContentsIndex
Main
Description

The top level for haskell to clojure translation. 61 |

This will: 64 |

  • Provide functionality to inspecting haskell ASTs via the haskell-src-exts package 68 |
  • Use the translform rules from Clojure.Translate to translate a Haskell AST to a clojure equivilant 71 | into the clojure AST in Clojure.Syntax 72 |
  • call the code generator in Clojure.CodeGen and write the results to a file 75 |
Produced by Haddock version 2.4.2
101 | -------------------------------------------------------------------------------- /docs/Translator.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Translator
ContentsIndex
Translator
Description

The top level for haskell to clojure translation. 61 |

This will: 64 |

  • Provide functionality to inspecting haskell ASTs via the haskell-src-exts package 68 |
  • Use the translform rules from Clojure.Translate to translate a Haskell AST to a clojure equivilant 71 | into the clojure AST in Clojure.Syntax 72 |
  • call the code generator in Clojure.CodeGen and write the results to a file 75 |
Produced by Haddock version 2.4.2
101 | -------------------------------------------------------------------------------- /docs/doc-index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | (Index)
ContentsIndex
Search:
ApplyClojure.Syntax
AtomClojure.Syntax
AtomicClojure.Syntax
Binds
1 (Type/Class)Clojure.Syntax
2 (Data Constructor)Clojure.Syntax
ConsClojure.Syntax
DoClojure.Syntax
fromPatternClojure.CodeGen
FuncClojure.Syntax
GenClojure.Syntax
genClojure.CodeGen
genatomClojure.CodeGen
genbindpairClojure.CodeGen
genBodyClojure.CodeGen
gencondpairClojure.CodeGen
GenerateableClojure.CodeGen
genfunctionClojure.CodeGen
genLambdaClojure.CodeGen
genNamespaceClojure.CodeGen
genpairClojure.CodeGen
genParamClojure.CodeGen
gensexpClojure.CodeGen
genStmtClojure.CodeGen
getclojureastMain
gethaskellastMain
IdentClojure.Syntax
IFClojure.Syntax
indentClojure.CodeGen
InfixApplyClojure.Syntax
IntClojure.Syntax
LambdaClojure.Syntax
LetClojure.Syntax
LetStmtClojure.Syntax
ListClojure.Syntax
ListCompClojure.Syntax
LitClojure.Syntax
mainMain
matchnameClojure.Translate
modstringClojure.Translate
Namespace
1 (Type/Class)Clojure.Syntax
2 (Data Constructor)Clojure.Syntax
NilClojure.Syntax
PatClojure.Syntax
PatternClojure.Syntax
PInfixApplyClojure.Syntax
PlistClojure.Syntax
printastSrcMain
PtrueClojure.Syntax
PtupleClojure.Syntax
QualifierClojure.Syntax
SexpClojure.Syntax
StmtClojure.Syntax
StringClojure.Syntax
SymbolClojure.Syntax
testMain
test1Main
test10Main
test11Main
test12Main
test13Main
test2Main
test3Main
test4Main
test5Main
test6Main
test7Main
test8Main
test9Main
translateClojure.Translate
TranslateableClojure.Translate
translateBDeclClojure.Translate
translateBindsClojure.Translate
translateDeclClojure.Translate
translateExpClojure.Translate
translateFileMain
translateLiteralClojure.Translate
translateMatchClojure.Translate
translateModuleClojure.Translate
translateNameClojure.Translate
translatePatternClojure.Translate
translateQNameClojure.Translate
translateQOPClojure.Translate
translateQualStmtClojure.Translate
translateSpecialClojure.Translate
translateStmtClojure.Translate
TupleClojure.Syntax
VarClojure.Syntax
VoidClojure.Syntax
WildCardClojure.Syntax
707 | -------------------------------------------------------------------------------- /docs/frames.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /docs/haddock-util.js: -------------------------------------------------------------------------------- 1 | // Haddock JavaScript utilities 2 | function toggle(button,id) 3 | { 4 | var n = document.getElementById(id).style; 5 | if (n.display == "none") 6 | { 7 | button.src = "minus.gif"; 8 | n.display = "block"; 9 | } 10 | else 11 | { 12 | button.src = "plus.gif"; 13 | n.display = "none"; 14 | } 15 | } 16 | 17 | 18 | var max_results = 75; // 50 is not enough to search for map in the base libraries 19 | var shown_range = null; 20 | var last_search = null; 21 | 22 | function quick_search() 23 | { 24 | perform_search(false); 25 | } 26 | 27 | function full_search() 28 | { 29 | perform_search(true); 30 | } 31 | 32 | 33 | function perform_search(full) 34 | { 35 | var text = document.getElementById("searchbox").value.toLowerCase(); 36 | if (text == last_search && !full) return; 37 | last_search = text; 38 | 39 | var table = document.getElementById("indexlist"); 40 | var status = document.getElementById("searchmsg"); 41 | var children = table.firstChild.childNodes; 42 | 43 | // first figure out the first node with the prefix 44 | var first = bisect(-1); 45 | var last = (first == -1 ? -1 : bisect(1)); 46 | 47 | if (first == -1) 48 | { 49 | table.className = ""; 50 | status.innerHTML = "No results found, displaying all"; 51 | } 52 | else if (first == 0 && last == children.length - 1) 53 | { 54 | table.className = ""; 55 | status.innerHTML = ""; 56 | } 57 | else if (last - first >= max_results && !full) 58 | { 59 | table.className = ""; 60 | status.innerHTML = "More than " + max_results + ", press Search to display"; 61 | } 62 | else 63 | { 64 | // decide what you need to clear/show 65 | if (shown_range) 66 | setclass(shown_range[0], shown_range[1], "indexrow"); 67 | setclass(first, last, "indexshow"); 68 | shown_range = [first, last]; 69 | table.className = "indexsearch"; 70 | status.innerHTML = ""; 71 | } 72 | 73 | 74 | function setclass(first, last, status) 75 | { 76 | for (var i = first; i <= last; i++) 77 | { 78 | children[i].className = status; 79 | } 80 | } 81 | 82 | 83 | // do a binary search, treating 0 as ... 84 | // return either -1 (no 0's found) or location of most far match 85 | function bisect(dir) 86 | { 87 | var first = 0, finish = children.length - 1; 88 | var mid, success = false; 89 | 90 | while (finish - first > 3) 91 | { 92 | mid = Math.floor((finish + first) / 2); 93 | 94 | var i = checkitem(mid); 95 | if (i == 0) i = dir; 96 | if (i == -1) 97 | finish = mid; 98 | else 99 | first = mid; 100 | } 101 | var a = (dir == 1 ? first : finish); 102 | var b = (dir == 1 ? finish : first); 103 | for (var i = b; i != a - dir; i -= dir) 104 | { 105 | if (checkitem(i) == 0) return i; 106 | } 107 | return -1; 108 | } 109 | 110 | 111 | // from an index, decide what the result is 112 | // 0 = match, -1 is lower, 1 is higher 113 | function checkitem(i) 114 | { 115 | var s = getitem(i).toLowerCase().substr(0, text.length); 116 | if (s == text) return 0; 117 | else return (s > text ? -1 : 1); 118 | } 119 | 120 | 121 | // from an index, get its string 122 | // this abstracts over alternates 123 | function getitem(i) 124 | { 125 | for ( ; i >= 0; i--) 126 | { 127 | var s = children[i].firstChild.firstChild.data; 128 | if (s.indexOf(' ') == -1) 129 | return s; 130 | } 131 | return ""; // should never be reached 132 | } 133 | } 134 | 135 | function setSynopsis(filename) { 136 | if (parent.window.synopsis) { 137 | parent.window.synopsis.location = filename; 138 | } 139 | } 140 | -------------------------------------------------------------------------------- /docs/haddock.css: -------------------------------------------------------------------------------- 1 | /* -------- Global things --------- */ 2 | 3 | BODY { 4 | background-color: #ffffff; 5 | color: #000000; 6 | font-family: sans-serif; 7 | padding: 0 0; 8 | } 9 | 10 | A:link { color: #0000e0; text-decoration: none } 11 | A:visited { color: #0000a0; text-decoration: none } 12 | A:hover { background-color: #e0e0ff; text-decoration: none } 13 | 14 | TABLE.vanilla { 15 | width: 100%; 16 | border-width: 0px; 17 | /* I can't seem to specify cellspacing or cellpadding properly using CSS... */ 18 | } 19 | 20 | TABLE.vanilla2 { 21 | border-width: 0px; 22 | } 23 | 24 | /* font is a little too small in MSIE */ 25 | TT { font-size: 100%; } 26 | PRE { font-size: 100%; } 27 | 28 | LI P { margin: 0pt } 29 | 30 | TD { 31 | border-width: 0px; 32 | } 33 | 34 | TABLE.narrow { 35 | border-width: 0px; 36 | } 37 | 38 | TD.s8 { height: 8px; } 39 | TD.s15 { height: 15px; } 40 | 41 | SPAN.keyword { text-decoration: underline; } 42 | 43 | /* Resize the buttom image to match the text size */ 44 | IMG.coll { width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em } 45 | 46 | /* --------- Contents page ---------- */ 47 | 48 | DIV.node { 49 | padding-left: 3em; 50 | } 51 | 52 | DIV.cnode { 53 | padding-left: 1.75em; 54 | } 55 | 56 | SPAN.pkg { 57 | position: absolute; 58 | left: 50em; 59 | } 60 | 61 | /* --------- Documentation elements ---------- */ 62 | 63 | TD.children { 64 | padding-left: 25px; 65 | } 66 | 67 | TD.synopsis { 68 | padding: 2px; 69 | background-color: #f0f0f0; 70 | font-family: monospace 71 | } 72 | 73 | TD.decl { 74 | padding: 2px; 75 | background-color: #f0f0f0; 76 | font-family: monospace; 77 | vertical-align: top; 78 | } 79 | 80 | TD.topdecl { 81 | padding: 2px; 82 | background-color: #f0f0f0; 83 | font-family: monospace; 84 | vertical-align: top; 85 | } 86 | 87 | TABLE.declbar { 88 | border-spacing: 0px; 89 | } 90 | 91 | TD.declname { 92 | width: 100%; 93 | } 94 | 95 | TD.declbut { 96 | padding-left: 5px; 97 | padding-right: 5px; 98 | border-left-width: 1px; 99 | border-left-color: #000099; 100 | border-left-style: solid; 101 | white-space: nowrap; 102 | font-size: small; 103 | } 104 | 105 | /* 106 | arg is just like decl, except that wrapping is not allowed. It is 107 | used for function and constructor arguments which have a text box 108 | to the right, where if wrapping is allowed the text box squashes up 109 | the declaration by wrapping it. 110 | */ 111 | TD.arg { 112 | padding: 2px; 113 | background-color: #f0f0f0; 114 | font-family: monospace; 115 | vertical-align: top; 116 | white-space: nowrap; 117 | } 118 | 119 | TD.recfield { padding-left: 20px } 120 | 121 | TD.doc { 122 | padding-top: 2px; 123 | padding-left: 10px; 124 | } 125 | 126 | TD.ndoc { 127 | padding: 2px; 128 | } 129 | 130 | TD.rdoc { 131 | padding: 2px; 132 | padding-left: 10px; 133 | width: 100%; 134 | } 135 | 136 | TD.body { 137 | padding-left: 10px 138 | } 139 | 140 | TD.pkg { 141 | width: 100%; 142 | padding-left: 10px 143 | } 144 | 145 | TABLE.indexsearch TR.indexrow { 146 | display: none; 147 | } 148 | TABLE.indexsearch TR.indexshow { 149 | display: table-row; 150 | } 151 | 152 | TD.indexentry { 153 | vertical-align: top; 154 | padding-right: 10px 155 | } 156 | 157 | TD.indexannot { 158 | vertical-align: top; 159 | padding-left: 20px; 160 | white-space: nowrap 161 | } 162 | 163 | TD.indexlinks { 164 | width: 100% 165 | } 166 | 167 | /* ------- Section Headings ------- */ 168 | 169 | TD.section1 { 170 | padding-top: 15px; 171 | font-weight: bold; 172 | font-size: 150% 173 | } 174 | 175 | TD.section2 { 176 | padding-top: 10px; 177 | font-weight: bold; 178 | font-size: 130% 179 | } 180 | 181 | TD.section3 { 182 | padding-top: 5px; 183 | font-weight: bold; 184 | font-size: 110% 185 | } 186 | 187 | TD.section4 { 188 | font-weight: bold; 189 | font-size: 100% 190 | } 191 | 192 | /* -------------- The title bar at the top of the page */ 193 | 194 | TD.infohead { 195 | color: #ffffff; 196 | font-weight: bold; 197 | padding-right: 10px; 198 | text-align: left; 199 | } 200 | 201 | TD.infoval { 202 | color: #ffffff; 203 | padding-right: 10px; 204 | text-align: left; 205 | } 206 | 207 | TD.topbar { 208 | background-color: #000099; 209 | padding: 5px; 210 | } 211 | 212 | TD.title { 213 | color: #ffffff; 214 | padding-left: 10px; 215 | width: 100% 216 | } 217 | 218 | TD.topbut { 219 | padding-left: 5px; 220 | padding-right: 5px; 221 | border-left-width: 1px; 222 | border-left-color: #ffffff; 223 | border-left-style: solid; 224 | white-space: nowrap; 225 | } 226 | 227 | TD.topbut A:link { 228 | color: #ffffff 229 | } 230 | 231 | TD.topbut A:visited { 232 | color: #ffff00 233 | } 234 | 235 | TD.topbut A:hover { 236 | background-color: #6060ff; 237 | } 238 | 239 | TD.topbut:hover { 240 | background-color: #6060ff 241 | } 242 | 243 | TD.modulebar { 244 | background-color: #0077dd; 245 | padding: 5px; 246 | border-top-width: 1px; 247 | border-top-color: #ffffff; 248 | border-top-style: solid; 249 | } 250 | 251 | /* --------- The page footer --------- */ 252 | 253 | TD.botbar { 254 | background-color: #000099; 255 | color: #ffffff; 256 | padding: 5px 257 | } 258 | TD.botbar A:link { 259 | color: #ffffff; 260 | text-decoration: underline 261 | } 262 | TD.botbar A:visited { 263 | color: #ffff00 264 | } 265 | TD.botbar A:hover { 266 | background-color: #6060ff 267 | } 268 | 269 | /* --------- Mini Synopsis for Frame View --------- */ 270 | 271 | .outer { 272 | margin: 0 0; 273 | padding: 0 0; 274 | } 275 | 276 | .mini-synopsis { 277 | padding: 0.25em 0.25em; 278 | } 279 | 280 | .mini-synopsis H1 { font-size: 130%; } 281 | .mini-synopsis H2 { font-size: 110%; } 282 | .mini-synopsis H3 { font-size: 100%; } 283 | .mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 { 284 | margin-top: 0.5em; 285 | margin-bottom: 0.25em; 286 | padding: 0 0; 287 | } 288 | 289 | .mini-synopsis H1 { border-bottom: 1px solid #ccc; } 290 | 291 | .mini-topbar { 292 | font-size: 130%; 293 | background: #0077dd; 294 | padding: 0.25em; 295 | } 296 | 297 | 298 | -------------------------------------------------------------------------------- /docs/haskell_icon.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dmead/Clojure-translate/10b17011a0b6dc826e7d4ce203092b3dfc257b18/docs/haskell_icon.gif -------------------------------------------------------------------------------- /docs/index-frames.html: -------------------------------------------------------------------------------- 1 | 2 | 3 |

Clojure.CodeGen
Clojure.Syntax
Clojure.Translate
Main

32 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 |
ContentsIndex
Modules
show/hideClojure
Clojure.CodeGen
Clojure.Syntax
Clojure.Translate
Main
Produced by Haddock version 2.4.2
114 | -------------------------------------------------------------------------------- /docs/mini_Clojure-CodeGen.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Clojure.CodeGen
Clojure.CodeGen
class Generateable a
genNamespace
gensexp
genpair
genbindpair
gencondpair
genfunction
genatom
56 | -------------------------------------------------------------------------------- /docs/mini_Clojure-Syntax.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Clojure.Syntax
Clojure.Syntax
data Namespace
data Pattern
data Stmt
data Atom
data Sexp
data Binds
58 | -------------------------------------------------------------------------------- /docs/mini_Clojure-Translate.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Clojure.Translate
Clojure.Translate
class Translateable a
translateModule
translateDecl
translateQName
translateSpecial
translateQOP
translateExp
translateMatch
56 | -------------------------------------------------------------------------------- /docs/mini_Main.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Main
Main
22 | -------------------------------------------------------------------------------- /docs/mini_Translator.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Translator
Translator
22 | -------------------------------------------------------------------------------- /docs/minus.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dmead/Clojure-translate/10b17011a0b6dc826e7d4ce203092b3dfc257b18/docs/minus.gif -------------------------------------------------------------------------------- /docs/plus.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dmead/Clojure-translate/10b17011a0b6dc826e7d4ce203092b3dfc257b18/docs/plus.gif -------------------------------------------------------------------------------- /makedocs: -------------------------------------------------------------------------------- 1 | haddock Main.hs -h -o docs 2 | -------------------------------------------------------------------------------- /tests/add.hs: -------------------------------------------------------------------------------- 1 | add x y = x + y 2 | 3 | 4 | addtuple (x,y) = x + y -------------------------------------------------------------------------------- /tests/add.hs.clj: -------------------------------------------------------------------------------- 1 | (defn add[params] 2 | (let [ 3 | b0 (match `x params) 4 | lparam (gensym "l") 5 | lbinds (gensym "b1") ] 6 | (cond 7 | (matches b0) (eval (applyBinds b0 8 | `(fn [~lparam] (let [~lbinds (match `y ~lparam)] 9 | (cond (matches ~lbinds) (eval (applyBinds ~lbinds `(+ x y)))))))) 10 | 11 | true (list :patternmatchfail add params) ))) 12 | 13 | 14 | (defn add[params] 15 | (let [ 16 | b0 (match `(x y ) params) 17 | ] 18 | (cond 19 | (matches b0 ) (eval (applyBinds b0 `(+ x y))) 20 | true (list :patternmatchfail addtuple params) ))) 21 | 22 | 23 | -------------------------------------------------------------------------------- /tests/addtest.clj: -------------------------------------------------------------------------------- 1 | (defn add[params] 2 | (let [ 3 | b0 (match `x params) 4 | lparam (gensym "l") 5 | lbinds (gensym "b1") 6 | ] 7 | (cond 8 | (matches b0) 9 | (eval (applyBinds ~b0 10 | `(fn [~lparam] 11 | (let [~lbinds (match `params ~lparam)] 12 | (cond (matches ~lbinds) 13 | (eval 14 | (applyBinds 15 | ~lbinds 16 | `(matches ~b0 ) 17 | (eval (applyBinds ~b0 (+ x y))) ))))))) 18 | 19 | 20 | true (list :patternmatchfail add params) ))) 21 | 22 | 23 | (defn addtuple[params] 24 | (let [ 25 | b0 (match `(x y ) params) 26 | lparam (gensym "l") 27 | lbinds (gensym "b1") ] 28 | (cond 29 | (matches b0 ) (eval (applyBinds b0`(+ x y))) 30 | true (list :patternmatchfail addtuple params) ))) 31 | 32 | 33 | -------------------------------------------------------------------------------- /tests/compSimple.hs: -------------------------------------------------------------------------------- 1 | t1 q = [x | x <-[1,2,3,4,5,6,7,8,9,10]] -------------------------------------------------------------------------------- /tests/compSimple.hs.clj: -------------------------------------------------------------------------------- 1 | (defn t1[params] 2 | (let [ 3 | b0 (match `q params) 4 | lparam (gensym "l") 5 | lbinds (gensym "b1") ] 6 | (cond 7 | (matches b0 ) (eval (applyBinds b0 `(flatmap (list (fn [x](cons x ())) (list 1 2 3 4 5 6 7 8 9 10 ) )))) 8 | 9 | true (list :patternmatchfail t1 params) ))) 10 | 11 | 12 | -------------------------------------------------------------------------------- /tests/comprehensions.hs: -------------------------------------------------------------------------------- 1 | {- 2 | test comprehensions for translation 3 | -} 4 | 5 | --we needd a non curried zip 6 | tzip ([],[]) = [] 7 | tzip (x:xs,y:ys) = (x,y) : tzip(xs,ys) 8 | 9 | --1. simple stuff 10 | 11 | listid n = [x | x <- n] 12 | 13 | squareall l = [ x * x | x <- l] 14 | 15 | 16 | --2. quicksort 17 | qs [] = [] 18 | qs (h:t) = qs[x | x<-t, x<=h] ++ h:qs[x | x<-t, x>h] 19 | 20 | 21 | 22 | --3. sort from the peyton-jones book, nearly the same 23 | sort [] = [] 24 | sort (x:xs) = sort [y | y <- xs, y < x] 25 | ++ [x]++ 26 | sort [y | y <- xs, y >= x] 27 | 28 | 29 | 30 | --4. vector addition, also from the book 31 | vecAdd (xs,ys) = [x + y | (x,y) <- tzip (xs,ys)] 32 | 33 | 34 | --5. singletons filters a list of ints for the singleton lists 35 | singletons xs = [ x | [x] <- xs] 36 | 37 | 38 | 39 | --6. example from the langauge definition 40 | c1 _ =[ x | xs <- [ [(1,2),(3,4)], [(5,4),(3,2)] ], 41 | (3,x) <- xs ] 42 | 43 | --7. cartesian product 44 | cartesian (s1,s2) = [(x, y) | x <- s1, y <- s2] 45 | 46 | 47 | 48 | --8. fibinacci sequence from the langauge tutorials 49 | --fibs _ = 0 : 1 : [a + b | (a,b) <- tzip (fibs 0 ,(tail fibs ))] 50 | -------------------------------------------------------------------------------- /tests/comprehensions.hs.clj: -------------------------------------------------------------------------------- 1 | (defn tzip[params] 2 | (let [ 3 | b0 (match `(() () ) params) 4 | b1 (match `((cons x xs) (cons y ys) ) params) 5 | lparam (gensym "l") 6 | lbinds (gensym "b1") ] 7 | (cond 8 | (matches b0 ) (eval (applyBinds b0 `())) 9 | (matches b1 ) (eval (applyBinds b1 `(cons (list x y ) (tzip (list xs ys ))))) 10 | 11 | true (list :patternmatchfail tzip params) ))) 12 | 13 | 14 | (defn listid[params] 15 | (let [ 16 | b0 (match `n params) 17 | lparam (gensym "l") 18 | lbinds (gensym "b1") ] 19 | (cond 20 | (matches b0 ) (eval (applyBinds b0 `(flatmap (list (fn [~lparam](cons ~lparam ())) n )))) 21 | 22 | true (list :patternmatchfail listid params) ))) 23 | 24 | 25 | (defn squareall[params] 26 | (let [ 27 | b0 (match `l params) 28 | lparam (gensym "l") 29 | ] 30 | (cond 31 | (matches b0 ) (eval (applyBinds b0 `(flatmap (list (fn [~lparam](cons (* ~lparam ~lparam) ())) l )))) 32 | 33 | true (list :patternmatchfail squareall params) ))) 34 | 35 | 36 | (defn squareall[params] 37 | (let [ 38 | b0 (match `l params) 39 | lparam (gensym "l") 40 | lbinds (gensym "b1") ](defn qs[params] 41 | (let [ 42 | b0 (match `() params) 43 | b1 (match `(cons h t) params) 44 | lparam (gensym "l") 45 | lbinds (gensym "b1") ] 46 | (cond 47 | (matches b0 ) (eval (applyBinds b0 `())) 48 | (matches b1 ) (eval (applyBinds b1 `(++ (qs (flatmap (list (fn [~lparam](if (<= ~lparam h)(cons ~lparam ())())) t ))) (cons h (qs (flatmap (list (fn [~lparam](if (> ~lparam h)(cons ~lparam ())())) t ))))))) 49 | 50 | true (list :patternmatchfail qs params) ))) 51 | 52 | 53 | (defn sort[params] 54 | (let [ 55 | b0 (match `() params) 56 | b1 (match `(cons x xs) params) 57 | lparam (gensym "l") 58 | lbinds (gensym "b1") ] 59 | (cond 60 | (matches b0 ) (eval (applyBinds b0 `())) 61 | (matches b1 ) (eval (applyBinds b1 `(++ (sort (flatmap (list (fn [y](if (< y x)(cons y ())())) xs ))) (++ (list x ) (sort (flatmap (list (fn [y](if (>= y x)(cons y ())())) xs ))))))) 62 | 63 | true (list :patternmatchfail sort params) ))) 64 | 65 | 66 | (defn vecAdd[params] 67 | (let [ 68 | b0 (match `(xs ys ) params) 69 | lparam (gensym "l") 70 | lparam1 (gensym "l") 71 | lbinds (gensym "b1") ] 72 | (cond 73 | (matches b0 ) (applyBinds b0 `(flatmap (list (fn [[~lparam ~lparam1] ](cons (+ ~lparam ~lparam1) ())) (tzip (list xs ys )) ))) 74 | 75 | true (list :patternmatchfail vecAdd params) ))) 76 | 77 | 78 | (defn singletons[params] 79 | (let [ 80 | b0 (match `xs params) 81 | lparam (gensym "l") 82 | lbinds (gensym "b1") ] 83 | (cond 84 | (matches b0 ) (eval (applyBinds b0 `(flatmap (list (fn [(x )](cons x ())) xs )))) 85 | 86 | true (list :patternmatchfail singletons params) ))) 87 | 88 | 89 | (defn c1[params] 90 | (let [ 91 | b0 (match `_ params) 92 | lparam (gensym "l") 93 | lbinds (gensym "b1") ] 94 | (cond 95 | (matches b0 ) (eval (applyBinds b0 `(flatmap (list (fn [xs](flatmap (list (fn [(3 x )](cons x ())) xs ))) (list (list (list 1 2 ) (list 3 4 ) ) (list (list 5 4 ) (list 3 2 ) ) ) )))) 96 | 97 | true (list :patternmatchfail c1 params) ))) 98 | 99 | 100 | (defn cartesian[params] 101 | (let [ 102 | b0 (match `(s1 s2 ) params) 103 | lparam (gensym "l") 104 | lbinds (gensym "b1") ] 105 | (cond 106 | (matches b0 ) (eval (applyBinds b0 `(flatmap (list (fn [x](flatmap (list (fn [y](cons (list x y ) ())) s2 ))) s1 )))) 107 | 108 | true (list :patternmatchfail cartesian params) ))) 109 | 110 | 111 | -------------------------------------------------------------------------------- /tests/curry_example.hs: -------------------------------------------------------------------------------- 1 | add3 x y z = x + y + z -------------------------------------------------------------------------------- /tests/curry_example.hs.clj: -------------------------------------------------------------------------------- 1 | (defn add3[params] 2 | (let [ 3 | b0 (match `x params) 4 | lparam (gensym "l") 5 | lbinds (gensym "b1") ] 6 | (cond 7 | (matches b0) (eval (applyBinds b0 `(fn [~lparam] (let [~lbinds (match `y ~lparam)] 8 | (cond (matches ~lbinds) (eval (applyBinds ~lbinds `(fn [~lparam] (let [~lbinds (match `z ~lparam)] 9 | (cond (matches ~lbinds) (eval (applyBinds ~lbinds `(+ (+ x y) z))))))))))))) 10 | 11 | true (list :patternmatchfail add3 params) ))) 12 | 13 | 14 | -------------------------------------------------------------------------------- /tests/curryexample.clj: -------------------------------------------------------------------------------- 1 | (defn addcurry [param] 2 | (let [b0 (match 'x param)] 3 | (cond 4 | (matches b0) 5 | (eval (applyBinds b0 6 | '(fn [p2] (let [b0 (match 'y p2)] 7 | (+ x y))))) 8 | true (list :fail addcurry param)))) -------------------------------------------------------------------------------- /tests/demo.hs: -------------------------------------------------------------------------------- 1 | -- 2 | 3 | add (x,y) = x + y 4 | 5 | add1 x y = x + y 6 | 7 | 8 | 9 | mysum [] = 0 10 | mysum (x:xs) = x + mysum xs 11 | 12 | 13 | mymap f [] = [] 14 | mymap f (x:xs) = f x : mymap f xs 15 | 16 | 17 | mymap1 (f,[]) = [] 18 | mymap1 (f,x:xs) = (f x) : mymap1(f, xs) 19 | 20 | 21 | 22 | 23 | 24 | cart xs ys = [(x,y) | x <- xs, y <- ys] 25 | 26 | 27 | -------------------------------------------------------------------------------- /tests/demo.hs.clj: -------------------------------------------------------------------------------- 1 | (defn add[params] 2 | (let [ 3 | b0 (match `(x y ) params) 4 | lparam (gensym "l") 5 | lbinds (gensym "b1") ] 6 | (cond 7 | (matches b0 ) (eval (applyBinds b0 `(+ x y))) 8 | 9 | true (list :patternmatchfail add params) ))) 10 | 11 | 12 | (defn add1[params] 13 | (let [ 14 | b0 (match `x params) 15 | lparam (gensym "l") 16 | lbinds (gensym "b1") ] 17 | (cond 18 | (matches b0) (eval (applyBinds b0 `(fn [~lparam] (let [~lbinds (match `y ~lparam)] 19 | (cond (matches ~lbinds) (eval (applyBinds ~lbinds `(+ x y)))))))) 20 | 21 | true (list :patternmatchfail add1 params) ))) 22 | 23 | 24 | (defn mysum[params] 25 | (let [ 26 | b0 (match `() params) 27 | b1 (match `(cons x xs) params) 28 | lparam (gensym "l") 29 | lbinds (gensym "b1") ] 30 | (cond 31 | (matches b0 ) (eval (applyBinds b0 `0)) 32 | (matches b1 ) (eval (applyBinds b1 `(+ x (mysum xs)))) 33 | 34 | true (list :patternmatchfail mysum params) ))) 35 | 36 | 37 | (defn mymap[params] 38 | (let [ 39 | b0 (match `f params) 40 | b1 (match `f params) 41 | lparam (gensym "l") 42 | lbinds (gensym "b1") ] 43 | (cond 44 | (matches b0) (eval (applyBinds b0 `(fn [~lparam] (let [~lbinds (match `() ~lparam)] 45 | (cond (matches ~lbinds) (eval (applyBinds ~lbinds `()))))))) 46 | (matches b1) (eval (applyBinds b1 `(fn [~lparam] (let [~lbinds (match `(cons x xs) ~lparam)] 47 | (cond (matches ~lbinds) (eval (applyBinds ~lbinds `(cons (f x) ((mymap f) xs))))))))) 48 | 49 | true (list :patternmatchfail mymap params) ))) 50 | 51 | 52 | (defn mymap1[params] 53 | (let [ 54 | b0 (match `(f () ) params) 55 | b1 (match `(f (cons x xs) ) params) 56 | lparam (gensym "l") 57 | lbinds (gensym "b1") ] 58 | (cond 59 | (matches b0 ) (eval (applyBinds b0 `())) 60 | (matches b1 ) (eval (applyBinds b1 `(cons (f x) (mymap1 (list f xs ))))) 61 | 62 | true (list :patternmatchfail mymap1 params) ))) 63 | 64 | 65 | (defn cart[params] 66 | (let [ 67 | b0 (match `xs params) 68 | lparam (gensym "l") 69 | lbinds (gensym "b1") ] 70 | (cond 71 | (matches b0) (eval (applyBinds b0 `(fn [~lparam] (let [~lbinds (match `ys ~lparam)] 72 | (cond (matches ~lbinds) (eval (applyBinds ~lbinds `(flatmap (list (fn [x](flatmap (list (fn [y](cons (list x y ) ())) ys ))) xs ))))))))) 73 | 74 | true (list :patternmatchfail cart params) ))) 75 | 76 | 77 | -------------------------------------------------------------------------------- /tests/dosimple.hs: -------------------------------------------------------------------------------- 1 | {- 2 | test x = do y <- do x <- return $ x + x 3 | return $ x + 1 4 | return y 5 | 6 | -} -------------------------------------------------------------------------------- /tests/dosimple.hs.clj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dmead/Clojure-translate/10b17011a0b6dc826e7d4ce203092b3dfc257b18/tests/dosimple.hs.clj -------------------------------------------------------------------------------- /tests/guardtest.hs: -------------------------------------------------------------------------------- 1 | test 0 ="zero" 2 | test x | x > 2 = "bigger than two" 3 | | True = "less than two" 4 | 5 | {- 6 | 7 | Module (SrcLoc {srcFilename = "guardtest.hs", srcLine = 1, srcColumn = 1}) (ModuleName "Main") [] Nothing (Just [EVar (UnQual (Ident "main"))]) [] [FunBind [ 8 | 9 | Match (SrcLoc {srcFilename = "guardtest.hs", srcLine = 1, srcColumn = 1}) (Ident "test") [PLit (Int 0)] Nothing (UnGuardedRhs (Lit (String "zero"))) (BDecls []), 10 | 11 | Match (SrcLoc {srcFilename = "guardtest.hs", srcLine = 2, srcColumn = 1}) (Ident "test") [PVar (Ident "x")] 12 | 13 | Nothing (GuardedRhss 14 | [GuardedRhs (SrcLoc {srcFilename = "guardtest.hs", srcLine = 2, srcColumn = 8}) 15 | [Qualifier (InfixApp (Var (UnQual (Ident "x"))) (QVarOp (UnQual (Symbol ">"))) (Lit (Int 2)))] 16 | (Lit (String "bigger than two")), 17 | GuardedRhs (SrcLoc {srcFilename = "guardtest.hs", srcLine = 3, srcColumn = 8}) 18 | [Qualifier (Con (UnQual (Ident "True")))] (Lit (String "less than two"))]) (BDecls [])] 19 | 20 | ] 21 | module Main (main) where 22 | test 0 = "zero" 23 | test x 24 | | x > 2 = "bigger than two" 25 | | True = "less than two" -------------------------------------------------------------------------------- /tests/hanoi.hs: -------------------------------------------------------------------------------- 1 | dohanoi(0, _, _, _) = [] 2 | dohanoi(n, from, to, using) = 3 | dohanoi(n - 1, from, using, to) ++ 4 | [(from, to)] ++ 5 | dohanoi(n - 1, using, to, from) 6 | 7 | hanoi(n) = dohanoi(n, 1, 3, 2) -------------------------------------------------------------------------------- /tests/hanoi.hs.clj: -------------------------------------------------------------------------------- 1 | (defn dohanoi[params] 2 | (let [ 3 | b0 (match `(0 _ _ _ ) params) 4 | b1 (match `(n from to using ) params) 5 | lparam (gensym "l") 6 | lbinds (gensym "b1") ] 7 | (cond 8 | (matches b0 ) (eval (applyBinds b0 `())) 9 | (matches b1 ) (eval (applyBinds b1 `(++ (dohanoi (list (- n 1) from using to )) (++ (list (list from to ) ) (dohanoi (list (- n 1) using to from )))))) 10 | 11 | true (list :patternmatchfail dohanoi params) ))) 12 | 13 | 14 | (defn hanoi[params] 15 | (let [ 16 | b0 (match `n params) 17 | lparam (gensym "l") 18 | lbinds (gensym "b1") ] 19 | (cond 20 | (matches b0 ) (eval (applyBinds b0 `(dohanoi (list n 1 3 2 )))) 21 | 22 | true (list :patternmatchfail hanoi params) ))) 23 | 24 | 25 | -------------------------------------------------------------------------------- /tests/hello.hs: -------------------------------------------------------------------------------- 1 | module Hello where 2 | 3 | 4 | 5 | data What = Foo | Bar 6 | 7 | 8 | test x | x > 1 = return "hello" 9 | 10 | main = do x <- test 1 11 | print "hello" 12 | return () -------------------------------------------------------------------------------- /tests/lambda.hs: -------------------------------------------------------------------------------- 1 | add y = (\x -> x + y) -------------------------------------------------------------------------------- /tests/lambda.hs.clj: -------------------------------------------------------------------------------- 1 | (defn add[params] 2 | (let [ 3 | b0 (match `y params) 4 | lparam (gensym "l") 5 | lbinds (gensym "b1") ] 6 | (cond 7 | (matches b0) (eval (applyBinds b0 `(fn [x](+ x y)))) 8 | 9 | true (list :patternmatchfail add params) ))) 10 | 11 | 12 | -------------------------------------------------------------------------------- /tests/let.hs: -------------------------------------------------------------------------------- 1 | {- 2 | test1 x = let q = 1 3 | x = q + 1 4 | in x 5 | -} -------------------------------------------------------------------------------- /tests/let.hs.clj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dmead/Clojure-translate/10b17011a0b6dc826e7d4ce203092b3dfc257b18/tests/let.hs.clj -------------------------------------------------------------------------------- /tests/lists.hs: -------------------------------------------------------------------------------- 1 | trav [] = [] 2 | trav (x:xs) = x:trav xs 3 | -------------------------------------------------------------------------------- /tests/lists.hs.clj: -------------------------------------------------------------------------------- 1 | (defn trav[params] 2 | (let [ 3 | b0 (match `() params) 4 | b1 (match `(cons x xs) params) 5 | lparam (gensym "l") 6 | lbinds (gensym "b1") ] 7 | (cond 8 | (matches b0 ) (eval (applyBinds b0 `())) 9 | (matches b1 ) (eval (applyBinds b1 `(cons x (trav xs)))) 10 | 11 | true (list :patternmatchfail trav params) ))) 12 | 13 | 14 | -------------------------------------------------------------------------------- /tests/map.hs: -------------------------------------------------------------------------------- 1 | add1 x = x + 1 2 | 3 | 4 | mymap (f, []) = [] 5 | mymap (f, x:xs) = f x : mymap (f ,xs) 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /tests/map.hs.clj: -------------------------------------------------------------------------------- 1 | (defn add1[params] 2 | (let [ 3 | b0 (match `x params) 4 | lparam (gensym "l") 5 | lbinds (gensym "b1") ] 6 | (cond 7 | (matches b0 ) (eval (applyBinds b0 `(+ x 1))) 8 | 9 | true (list :patternmatchfail add1 params) ))) 10 | 11 | 12 | (defn mymap[params] 13 | (let [ 14 | b0 (match `(f () ) params) 15 | b1 (match `(f (cons x xs) ) params) 16 | lparam (gensym "l") 17 | lbinds (gensym "b1") ] 18 | (cond 19 | (matches b0 ) (eval (applyBinds b0 `())) 20 | (matches b1 ) (eval (applyBinds b1 `(cons (f x) (mymap (list f xs ))))) 21 | 22 | true (list :patternmatchfail mymap params) ))) 23 | 24 | 25 | -------------------------------------------------------------------------------- /tests/myflip.hs: -------------------------------------------------------------------------------- 1 | myflip [] = [] 2 | myflip [x] = [x] 3 | myflip (x:y:xs) = y:x:myflip xs -------------------------------------------------------------------------------- /tests/quicksort.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | filtergte (q,[]) = [] 4 | filtergte (q,(x:xs)) = 5 | if q <= x then x : (filtergte (q,xs)) 6 | else filtergte (q,xs) 7 | 8 | filterLT (q,[]) = [] 9 | filterLT (q,(x:xs)) = 10 | if q > x then [x] ++ (filterLT (q,xs)) 11 | else filterLT (q,xs) 12 | 13 | 14 | quicksort [] = [] 15 | quicksort (x:xs) = (quicksort (filterLT (x,xs))) 16 | ++ 17 | [x] 18 | ++ 19 | (quicksort (filtergte (x,xs))) 20 | 21 | mytake (0,_) = [] 22 | mytake (n,x:xs) = x:mytake(n-1,xs) 23 | 24 | 25 | 26 | fib 0 = 0 27 | fib 1 = 1 28 | fib n = fib (n-1) + fib (n-2) 29 | 30 | 31 | nth (0,x:xs) = x 32 | nth (n,x:xs) = nth(n-1,xs) -------------------------------------------------------------------------------- /tests/quicksort.hs.clj: -------------------------------------------------------------------------------- 1 | (defn filtergte[params] 2 | (let [ 3 | b0 (match `(q () ) params) 4 | b1 (match `(q (cons x xs) ) params) 5 | lparam (gensym "l") 6 | lbinds (gensym "b1") ] 7 | (cond 8 | (matches b0 ) (eval (applyBinds b0 `())) 9 | (matches b1 ) (eval (applyBinds b1 `(if (<= q x)(cons x (filtergte (list q xs )))(filtergte (list q xs ))))) 10 | 11 | true (list :patternmatchfail filtergte params) ))) 12 | 13 | 14 | (defn filterLT[params] 15 | (let [ 16 | b0 (match `(q () ) params) 17 | b1 (match `(q (cons x xs) ) params) 18 | lparam (gensym "l") 19 | lbinds (gensym "b1") ] 20 | (cond 21 | (matches b0 ) (eval (applyBinds b0 `())) 22 | (matches b1 ) (eval (applyBinds b1 `(if (> q x)(++ (list x ) (filterLT (list q xs )))(filterLT (list q xs ))))) 23 | 24 | true (list :patternmatchfail filterLT params) ))) 25 | 26 | 27 | (defn quicksort[params] 28 | (let [ 29 | b0 (match `() params) 30 | b1 (match `(cons x xs) params) 31 | lparam (gensym "l") 32 | lbinds (gensym "b1") ] 33 | (cond 34 | (matches b0 ) (eval (applyBinds b0 `())) 35 | (matches b1 ) (eval (applyBinds b1 `(++ (quicksort (filterLT (list x xs ))) (++ (list x ) (quicksort (filtergte (list x xs ))))))) 36 | 37 | true (list :patternmatchfail quicksort params) ))) 38 | 39 | 40 | (defn mytake[params] 41 | (let [ 42 | b0 (match `(0 _ ) params) 43 | b1 (match `(n (cons x xs) ) params) 44 | lparam (gensym "l") 45 | lbinds (gensym "b1") ] 46 | (cond 47 | (matches b0 ) (eval (applyBinds b0 `())) 48 | (matches b1 ) (eval (applyBinds b1 `(cons x (mytake (list (- n 1) xs ))))) 49 | 50 | true (list :patternmatchfail mytake params) ))) 51 | 52 | 53 | (defn fib[params] 54 | (let [ 55 | b0 (match `0 params) 56 | b1 (match `1 params) 57 | b2 (match `n params) 58 | lparam (gensym "l") 59 | lbinds (gensym "b1") ] 60 | (cond 61 | (matches b0 ) (eval (applyBinds b0 `0)) 62 | (matches b1 ) (eval (applyBinds b1 `1)) 63 | (matches b2 ) (eval (applyBinds b2 `(+ (fib (- n 1)) (fib (- n 2))))) 64 | 65 | true (list :patternmatchfail fib params) ))) 66 | 67 | 68 | (defn nth[params] 69 | (let [ 70 | b0 (match `(0 (cons x xs) ) params) 71 | b1 (match `(n (cons x xs) ) params) 72 | lparam (gensym "l") 73 | lbinds (gensym "b1") ] 74 | (cond 75 | (matches b0 ) (eval (applyBinds b0 x)) 76 | (matches b1 ) (eval (applyBinds b1 `(nth (list (- n 1) xs )))) 77 | 78 | true (list :patternmatchfail nth params) ))) 79 | 80 | 81 | -------------------------------------------------------------------------------- /tests/simpleadd.hs: -------------------------------------------------------------------------------- 1 | {- 2 | 3 | Module (SrcLoc {srcFilename = "simpleadd.hs", srcLine = 1, srcColumn = 1}) 4 | (ModuleName "Main") [] 5 | Nothing (Just [EVar (UnQual (Ident "main"))]) [] 6 | 7 | [ 8 | FunBind 9 | [Match (SrcLoc {srcFilename = "simpleadd.hs", srcLine = 1, srcColumn = 1}) 10 | (Ident "add") [PVar (Ident "x"),PVar (Ident "y")] 11 | Nothing (UnGuardedRhs (InfixApp (Var (UnQual (Ident "x"))) 12 | (QVarOp (UnQual (Symbol "+"))) 13 | (Var (UnQual (Ident "y"))))) 14 | (BDecls [])]] 15 | 16 | -} 17 | add x y = x + y -------------------------------------------------------------------------------- /tests/tupleadd.hs: -------------------------------------------------------------------------------- 1 | add (x,y) = x + y -------------------------------------------------------------------------------- /tests/tupleadd.hs.clj: -------------------------------------------------------------------------------- 1 | (defn add[params] 2 | (let [ 3 | b0 (match `(x y ) params) 4 | lparam (gensym "l") 5 | lbinds (gensym "b1") ] 6 | (cond 7 | (matches b0 ) (eval (applyBinds b0 `(+ x y))) 8 | 9 | true (list :patternmatchfail add params) ))) 10 | 11 | 12 | -------------------------------------------------------------------------------- /tests/workingcurry.clj: -------------------------------------------------------------------------------- 1 | (defn add3[params] 2 | (let [ 3 | b0 (match `x params) ;; bind x 4 | ] 5 | (cond 6 | (matches b0) 7 | (eval 8 | (applyBinds b0 9 | (let [param (gensym "l") 10 | binds (gensym "b")] 11 | `(fn [~param] 12 | (let [~binds (match `y ~param)] ;; bind y 13 | (cond (matches ~binds ) 14 | (eval (applyBinds ~binds 15 | `(fn [~param] 16 | (let [~binds (matches `y ~param)] ;; bind z 17 | (cond 18 | (matches ~binds) 19 | (eval (applyBinds ~binds '(+ (+ x y) z))) ))))))))))) 20 | 21 | true (list :patternmatchfail add3 params) ))) 22 | 23 | 24 | 25 | 26 | 27 | (defn add3[params] 28 | (let [ 29 | b0 (match `x params) ;; bind x 30 | ] 31 | (cond 32 | (matches b0) 33 | (eval (applyBinds b0 34 | (let [param (gensym "l") 35 | binds (gensym "b1")] 36 | `(fn [~param] 37 | (let [~binds (match `y ~param)] ;; bind y 38 | (cond (matches ~binds) 39 | (eval (applyBinds ~binds 40 | '(fn [~param] 41 | (let [~binds (match `z ~param)] 42 | 43 | (cond (matches ~binds) 44 | (eval (applyBinds ~binds 45 | '(fn [~param] 46 | (let [~binds (match `w ~param)] 47 | (cond (matches ~binds) 48 | (eval (applyBinds ~binds `(+ x y z w)))))))))))))))))))))) 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /translator_presentation.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dmead/Clojure-translate/10b17011a0b6dc826e7d4ce203092b3dfc257b18/translator_presentation.odp --------------------------------------------------------------------------------