├── HOAS.idr └── README.md /HOAS.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | %default total 4 | 5 | data PrimType 6 | = PInt 7 | | PChar 8 | | PVoid 9 | 10 | showTy : PrimType -> String 11 | showTy PInt = "int" 12 | showTy PChar = "char" 13 | showTy PVoid = "void" 14 | 15 | data Literal : PrimType -> Type where 16 | LInt : Integer -> Literal PInt 17 | LChar : Char -> Literal PChar 18 | 19 | showLiteral : Literal ty -> String 20 | showLiteral (LInt x) = show x 21 | showLiteral (LChar x) = singleton x 22 | 23 | data Variable : Type -> PrimType -> Type where 24 | MkVariable : (label : t) -> Variable t p 25 | 26 | showVariable : (label -> String) -> Variable label ty -> String 27 | showVariable showLabel (MkVariable label) = "var_" ++ showLabel label 28 | 29 | data Function : Type -> List PrimType -> PrimType -> Type where 30 | MkFunction : (label : t) -> Function t argTys retTy 31 | 32 | showFunction : (label -> String) -> Function label tys ty -> String 33 | showFunction showLabel (MkFunction label) = "function_" ++ showLabel label 34 | 35 | data Argument : PrimType -> Type where 36 | MkArgument : (ty : PrimType) -> Variable label ty -> Argument ty 37 | 38 | mutual 39 | genFunType : Type -> List PrimType -> PrimType -> Type 40 | genFunType label [] retTy = AST label retTy () 41 | genFunType label (ty::tys) retTy = Variable label ty -> genFunType label tys retTy 42 | 43 | data AST : Type -> PrimType -> Type -> Type where 44 | Lit : Literal p -> AST label p () 45 | Add : AST label PInt () -> AST label PInt () -> AST label PInt () 46 | Var : Variable label a -> AST label a () 47 | Declare : (ty : PrimType) -> (Variable label ty -> AST label a ()) -> AST label a () 48 | Assign : Variable label ty -> AST label ty () -> AST label ty () 49 | AssignThen : Variable label ty -> AST label ty () -> AST label ty' () -> AST label ty' () 50 | Define 51 | : (retTy : PrimType) 52 | -> (argTys : List PrimType) 53 | -> (Function label argTys retTy -> genFunType label argTys retTy) 54 | -> AST label PVoid () 55 | Skip : AST label ty a 56 | Return : AST label ty () -> AST label ty () 57 | 58 | interface Primitive ty (ty' : PrimType) where 59 | coerce : ty -> AST label ty' () 60 | 61 | Primitive Integer PInt where 62 | coerce = Lit . LInt 63 | 64 | term syntax int {name} ";" [rest] = Declare PInt (\name => rest) 65 | term syntax [ty] {name} ";" [rest] = Declare ty (\name => rest) 66 | term syntax int {name} "()" "{" [rest] "}" = Define PInt Nil (\name => rest) 67 | term syntax [ty] {name} "()" "{" [rest] "}" = Define ty Nil (\name => rest) 68 | term syntax [name] "=" [val] ";" [rest] = AssignThen name (coerce val) rest 69 | term syntax "(" [name] "=" [val] ")" = Assign name (coerce val) 70 | term syntax return [a] ";" = Return (coerce a) 71 | 72 | namespace ArgList 73 | data ArgList : Type -> List PrimType -> Type where 74 | Nil : ArgList label [] 75 | (::) : (var : Variable label t) -> ArgList label ts -> ArgList label (t::ts) 76 | 77 | showArgs : (label -> String) -> (tys : List PrimType) -> ArgList label tys -> String 78 | showArgs showLabel [] [] = "" 79 | showArgs showLabel [ty] [var] = showTy ty ++ " " ++ showVariable showLabel var 80 | showArgs showLabel (ty::tys) (var::vars) = 81 | showTy ty ++ " " ++ showVariable showLabel var ++ ", " ++ showArgs showLabel tys vars 82 | 83 | applyArgs 84 | : (argTys : List PrimType) 85 | -> Stream label 86 | -> (Function label argTys retTy -> genFunType label argTys retTy) 87 | -> ( Stream label 88 | , Function label argTys retTy 89 | , (as : List PrimType ** ArgList label as) 90 | , AST label retTy () 91 | ) 92 | applyArgs tys (funcName::labels) f = 93 | let func = MkFunction funcName 94 | (labels', hlist, ast) = go tys labels (f func) 95 | in (labels', func, hlist, ast) 96 | where 97 | go 98 | : (argTys : List PrimType) 99 | -> Stream label 100 | -> (genFunType label argTys retTy) 101 | -> ( Stream label 102 | , (as : List PrimType ** ArgList label as) 103 | , AST label retTy () 104 | ) 105 | go [] labels f = (labels, (_ ** Nil), f) 106 | go (ty::tys) (label::labels) f = 107 | let var = MkVariable label 108 | (labels', (_ ** hlist'), ast') = go tys labels (f var) 109 | in (labels', (_ ** var::hlist'), ast') 110 | 111 | showAST : (label -> String) -> Stream label -> AST label ty a -> String 112 | showAST showLabel labels Skip = "" 113 | showAST showLabel labels (AssignThen a b rest) = 114 | showAST showLabel labels (assert_smaller (AssignThen a b rest) (Assign a b)) ++ 115 | ";\n" ++ showAST showLabel labels rest 116 | showAST showLabel labels (Return x) = "return " ++ showAST showLabel labels x ++ ";" 117 | showAST showLabel labels (Lit x) = showLiteral x 118 | showAST showLabel labels (Add x y) = 119 | unwords 120 | [ showAST showLabel labels x 121 | , "+" 122 | , showAST showLabel labels y 123 | ] 124 | showAST showLabel labels (Var v) = showVariable showLabel v 125 | showAST showLabel (label::labels) (Declare ty f) = 126 | let var = MkVariable label 127 | in unlines 128 | [ unwords [ showTy ty, showVariable showLabel var ] ++ ";" 129 | , showAST showLabel labels $ f var 130 | ] 131 | showAST showLabel labels (Assign x y) = 132 | unwords 133 | [ showVariable showLabel x 134 | , "=" 135 | , showAST showLabel labels y 136 | ] 137 | showAST showLabel labels (Define retTy argTys f) = 138 | let (labels', f', (argTys' ** vars), ast) = applyArgs argTys labels f 139 | in unlines 140 | [ showTy retTy ++ " " ++ 141 | showFunction showLabel f' ++ 142 | "(" ++ showArgs showLabel argTys' vars ++ ") {" 143 | , showAST showLabel labels' (assert_smaller (Define retTy argTys f) ast) 144 | , "}" 145 | ] 146 | 147 | infinity : Stream Int 148 | infinity = iterate (+1) 0 149 | 150 | showASTCounted : AST Int ty a -> String 151 | showASTCounted = showAST show infinity 152 | 153 | test1 : AST label PVoid () 154 | test1 = Define PInt [PInt] $ \func, a => Var a 155 | 156 | test2 : AST label PVoid () 157 | test2 = Define PInt [PInt, PChar, PInt] $ \func, a, b, c => Add (Var a) (Var c) 158 | 159 | test3 : AST label PVoid () 160 | test3 = 161 | int main() { 162 | int a; 163 | a = 2; 164 | return 0; 165 | } 166 | 167 | main : IO () 168 | main = putStr $ showASTCounted test3 169 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Idris, but it's C 2 | 3 | A silly experiment where I build a type-safe, HOAS syntax tree for a small 4 | C-like language. By way of some syntax extensions, Idris will parse some valid 5 | C code into a [value which represents the corresponding program](https://github.com/LightAndLight/idris-but-its-c/blob/master/HOAS.idr#L160). 6 | --------------------------------------------------------------------------------