├── Benchmarks ├── pidigits.args ├── sortvec.args ├── pythagoras.args ├── Comparisons │ ├── pythagorasUnboxedStrict.icl │ ├── pythagorasUnboxedLazy.icl │ ├── build.ninja │ ├── pythagorasBoxedLazy.icl │ └── pythagorasBoxedStrict.icl ├── pythagoras.idr ├── sortvec.idr ├── build.ninja ├── pidigits.idr ├── fasta.idr └── quasigroups.idr ├── .gitignore ├── Tests ├── Foldables.idr ├── HelloWorld.idr ├── Show.idr ├── Streams.idr ├── Chars.idr ├── EffectsTest.idr ├── IfThenElse.idr ├── Records.idr ├── Nullable.idr ├── Doubles.idr ├── StrInt.idr ├── Ints.idr ├── PrimitiveArrays.idr ├── Lists.idr ├── SortedSet.idr ├── Data.idr ├── ReferenceTypeArrays.idr ├── Bits32.idr ├── ValueTypeProperties.idr ├── Vector.idr ├── ValueTypeArrays.idr ├── Enums.idr ├── HashSet.idr ├── SinglePrimitives.idr ├── Generics.idr ├── Strings.idr ├── Delegates.idr ├── build.ninja └── FFI.idr ├── rules.ninja ├── idris-clean.cabal ├── LICENSE ├── Sources ├── Main.hs └── IRTS │ └── CodegenClean.hs ├── Libraries ├── StdPointer.dcl └── StdPointer.icl └── README.md /Benchmarks/pidigits.args: -------------------------------------------------------------------------------- 1 | 1000 2 | -------------------------------------------------------------------------------- /Benchmarks/sortvec.args: -------------------------------------------------------------------------------- 1 | 2000 2 | -------------------------------------------------------------------------------- /Benchmarks/pythagoras.args: -------------------------------------------------------------------------------- 1 | 300 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | 3 | **/*.ibc 4 | **/*.icl 5 | **/*-id 6 | **/*-cl 7 | -------------------------------------------------------------------------------- /Tests/Foldables.idr: -------------------------------------------------------------------------------- 1 | {- 2 | 55 3 | -} 4 | module Main 5 | 6 | main : IO () 7 | main = printLn $ foldl (+) 0 [1..10] 8 | -------------------------------------------------------------------------------- /Tests/HelloWorld.idr: -------------------------------------------------------------------------------- 1 | {- 2 | Hello, Idris! 3 | -} 4 | module Main 5 | 6 | main : IO () 7 | main = putStrLn "Hello, Idris!" 8 | -------------------------------------------------------------------------------- /Tests/Show.idr: -------------------------------------------------------------------------------- 1 | {- 2 | A 42 3 | -} 4 | 5 | module Main 6 | 7 | data V a = A a 8 | 9 | Show a => Show (V a) where 10 | show (A a) = "A " ++ show a 11 | 12 | main : IO () 13 | main = printLn $ A 42 14 | -------------------------------------------------------------------------------- /Tests/Streams.idr: -------------------------------------------------------------------------------- 1 | {- 2 | Ni! 3 | Ni! 4 | Ni! 5 | -} 6 | module Main 7 | 8 | knight : IO () 9 | knight = putStrLn "Ni!" 10 | 11 | knights : Stream (IO ()) 12 | knights = repeat knight 13 | 14 | main : IO () 15 | main = for_ (take 3 knights) id 16 | -------------------------------------------------------------------------------- /Tests/Chars.idr: -------------------------------------------------------------------------------- 1 | {- 2 | foo 3 | bar 4 | baz 5 | 'q' 6 | 'u' 7 | 'x' 8 | -} 9 | module Main 10 | 11 | main : IO () 12 | main = do 13 | putStrLn . pack $ ['f', 'o', 'o'] 14 | for_ (words "bar baz ") putStrLn 15 | for_ (unpack "qux") (putStrLn . show) 16 | -------------------------------------------------------------------------------- /Tests/EffectsTest.idr: -------------------------------------------------------------------------------- 1 | {- 2 | Hello world! 3 | -} 4 | import CIL.FFI 5 | import CIL.FFI.Effects 6 | import Effects 7 | import Effect.StdIO 8 | 9 | hello : Eff () [STDIO] 10 | hello = putStrLn "Hello world!" 11 | 12 | main : CIL_IO () 13 | main = run hello 14 | -------------------------------------------------------------------------------- /Tests/IfThenElse.idr: -------------------------------------------------------------------------------- 1 | {- 2 | then 3 | else 4 | -} 5 | module Main 6 | 7 | test : Bool -> IO () 8 | test b = 9 | putStrLn $ 10 | if b 11 | then "then" 12 | else "else" 13 | 14 | main : IO () 15 | main = do 16 | test True 17 | test False 18 | -------------------------------------------------------------------------------- /Tests/Records.idr: -------------------------------------------------------------------------------- 1 | {- 2 | Idris 3 | -} 4 | module Main 5 | 6 | record Language where 7 | constructor MkLanguage 8 | name: String 9 | 10 | -- intentionally convoluted to avoid inlining 11 | Idris : IO Language 12 | Idris = pure $ MkLanguage "Idris" 13 | 14 | main : IO () 15 | main = putStrLn $ name !Idris 16 | -------------------------------------------------------------------------------- /Benchmarks/Comparisons/pythagorasUnboxedStrict.icl: -------------------------------------------------------------------------------- 1 | module pythagorasUnboxedStrict 2 | 3 | import StdEnv 4 | 5 | :: List a :== [a] 6 | 7 | pythagoras :: !Int -> List !(!Int, !Int, !Int) 8 | pythagoras max = [ 9 | (x, y, z) 10 | \\ z <- [1..max] 11 | , y <- [1..z] 12 | , x <- [1..y] 13 | | x * x + y * y == z * z 14 | ] 15 | 16 | Start = pythagoras 300 17 | -------------------------------------------------------------------------------- /Benchmarks/pythagoras.idr: -------------------------------------------------------------------------------- 1 | -- Shamelessly stolen from Edwin Brady 2 | module Main 3 | 4 | pythagoras : Int -> List (Int, Int, Int) 5 | pythagoras max = [ 6 | (x, y, z) 7 | | z <- [1..max] 8 | , y <- [1..z] 9 | , x <- [1..y] 10 | , x * x + y *y == z * z 11 | ] 12 | 13 | main : IO () 14 | main = do 15 | arg <- getLine 16 | printLn $ pythagoras (cast arg) 17 | -------------------------------------------------------------------------------- /Tests/Nullable.idr: -------------------------------------------------------------------------------- 1 | {- 2 | null 3 | not null 4 | -} 5 | 6 | import CIL.FFI 7 | 8 | putNullableStrLn : Nullable String -> IO () 9 | putNullableStrLn = 10 | putStrLn . nullable "null" id 11 | 12 | main : IO () 13 | main = do 14 | putNullableStrLn null 15 | putNullableStrLn (asNullable "not null") 16 | 17 | -- Local Variables: 18 | -- idris-load-packages: ("cil") 19 | -- End: 20 | -------------------------------------------------------------------------------- /Benchmarks/Comparisons/pythagorasUnboxedLazy.icl: -------------------------------------------------------------------------------- 1 | module pythagorasUnboxedLazy 2 | 3 | import StdEnv 4 | 5 | :: List a :== [a] 6 | 7 | // Probably inferred strict by the compiler 8 | pythagoras :: Int -> List (Int, Int, Int) 9 | pythagoras max = [ 10 | (x, y, z) 11 | \\ z <- [1..max] 12 | , y <- [1..z] 13 | , x <- [1..y] 14 | | x * x + y * y == z * z 15 | ] 16 | 17 | Start = pythagoras 300 18 | -------------------------------------------------------------------------------- /Tests/Doubles.idr: -------------------------------------------------------------------------------- 1 | {- 2 | 0.42 3 | 1.68 4 | 1.34 5 | 0.34 6 | 42 7 | 0 8 | -} 9 | module Main 10 | 11 | testNum : IO () 12 | testNum = 13 | traverse_ 14 | (\op => printLn $ 0.84 `op` 0.5) 15 | [(*), (/), (+), (-)] 16 | 17 | testStr : IO () 18 | testStr = 19 | for_ ["42.0", "not a double"] $ \s => 20 | printLn $ the Double (cast s) 21 | 22 | main : IO () 23 | main = do 24 | testNum 25 | testStr 26 | -------------------------------------------------------------------------------- /Tests/StrInt.idr: -------------------------------------------------------------------------------- 1 | {- 2 | 0 3 | 1 4 | 0 5 | -} 6 | module Main 7 | 8 | testInt : String -> IO () 9 | testInt s = do 10 | let x : Int = cast s 11 | putStrLn $ cast x 12 | 13 | testInteger : String -> IO () 14 | testInteger s = do 15 | let x : Integer = cast s 16 | putStrLn $ cast x 17 | 18 | main : IO () 19 | main = do 20 | traverse_ testInt ["0", "1", "abc"] 21 | --traverse_ testInteger ["0", "1", "abc"] 22 | -------------------------------------------------------------------------------- /Tests/Ints.idr: -------------------------------------------------------------------------------- 1 | {- 2 | < 3 | = 4 | > 5 | 6 6 | 2 7 | 8 8 | -} 9 | 10 | implementation Show Ordering where 11 | show LT = "<" 12 | show GT = ">" 13 | show EQ = "=" 14 | 15 | test : Ord a => a -> a -> IO () 16 | test x y = printLn $ compare x y 17 | 18 | l : List (Int, Int) 19 | l = [(33, 42), (42, 42), (42, 33)] 20 | 21 | main : IO () 22 | main = do 23 | traverse_ (uncurry test) l 24 | traverse_ (\op => printLn $ 4 `op` 2) [(+), (-), (*)] 25 | -------------------------------------------------------------------------------- /rules.ninja: -------------------------------------------------------------------------------- 1 | rule idris 2 | command = idris -p contrib -p effects $in -o $out 3 | rule idris-clean 4 | command = idris-codegen-clean $in -o $out 5 | rule idris-php 6 | command = idris-codegen-php $in -o $out 7 | rule clean 8 | command = clm -b -h 209715200 -I ../Libraries $$(basename -s .icl $in) -o $out 9 | rule clean-start 10 | command = clm -h 209715200 $$(basename -s .icl $in) -o $out 11 | rule eval 12 | command = eval ./$in > $out 13 | rule diff 14 | command = diff $in 15 | -------------------------------------------------------------------------------- /Tests/PrimitiveArrays.idr: -------------------------------------------------------------------------------- 1 | {- 2 | System.Int32[] 3 | 17 4 | 25 5 | 42 6 | -} 7 | import CIL.FFI.Array 8 | import Data.Vect 9 | 10 | infixl 5 >=> 11 | 12 | (>=>) : Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) 13 | (>=>) f g x = f x >>= g 14 | 15 | main : CIL_IO () 16 | main = do 17 | array <- arrayOf CILTyInt32 [17, 25] 18 | putStrLn !(ToString array) 19 | let a = \i => get array i 20 | for_ [0..1] $ 21 | a >=> printLn 22 | printLn (!(a 0) + !(a 1)) 23 | 24 | -- Local Variables: 25 | -- idris-load-packages: ("cil") 26 | -- End: 27 | -------------------------------------------------------------------------------- /Tests/Lists.idr: -------------------------------------------------------------------------------- 1 | {- 2 | 2 3 | 1 4 | 2 5 | 1 6 | 3 7 | 4 8 | -} 9 | module Main 10 | 11 | length' : List a -> Nat 12 | length' = length'' Z 13 | where length'' acc [] = acc 14 | length'' acc (x::xs) = length'' (S acc) xs 15 | 16 | printList : List String -> IO () 17 | printList (x :: xs) = putStrLn x *> printList xs 18 | printList [] = pure () 19 | 20 | main : IO () 21 | main = do printList $ (show . length') <$> lists 22 | printList $ show <$> sort [3, 4, 1] 23 | where lists : List (List Nat) 24 | lists = [[1..l] | l <- [0..2]] 25 | -------------------------------------------------------------------------------- /Tests/SortedSet.idr: -------------------------------------------------------------------------------- 1 | {- 2 | [(0, 1), (1, 0), (1, 1), (2, 2)] 3 | -} 4 | module Main 5 | 6 | import Data.SortedSet 7 | 8 | %hide merge 9 | 10 | Cell : Type 11 | Cell = (Int, Int) 12 | 13 | Nil : Ord k => SortedSet k 14 | Nil = SortedSet.empty 15 | 16 | (::) : Ord k => k -> SortedSet k -> SortedSet k 17 | (::) = insert 18 | 19 | Cells : Type 20 | Cells = SortedSet Cell 21 | 22 | Show Cells where 23 | show = show . SortedSet.toList 24 | 25 | merge : Cells -> Cells -> Cells 26 | merge xs ys = foldl (flip insert) xs (SortedSet.toList ys) 27 | 28 | main : IO () 29 | main = printLn $ [(0, 1), (1, 0), (2, 2)] `merge` [(1, 0), (0, 1), (1, 1)] 30 | -------------------------------------------------------------------------------- /Tests/Data.idr: -------------------------------------------------------------------------------- 1 | {- 2 | [1, 42, 51] 3 | True 4 | False 5 | -} 6 | module Main 7 | 8 | data T a = L | B a (T a) (T a) 9 | 10 | toList : T a -> List a 11 | toList L = [] 12 | toList (B a l r) = Main.toList l ++ [a] ++ Main.toList r 13 | 14 | contains : Ord a => T a -> a -> Bool 15 | contains L _ = False 16 | contains (B a l r) x = 17 | case (compare x a) of 18 | EQ => True 19 | LT => contains l x 20 | GT => contains r x 21 | 22 | main : IO () 23 | main = do printLn $ Main.toList tree 24 | printLn $ contains tree 1 25 | printLn $ contains tree 52 26 | where tree : T Nat 27 | tree = (B 42 (B 1 L L) (B 51 L L)) 28 | -------------------------------------------------------------------------------- /Benchmarks/Comparisons/build.ninja: -------------------------------------------------------------------------------- 1 | include ../../rules.ninja 2 | 3 | build pythagorasBoxedLazy-cl: clean-start pythagorasBoxedLazy.icl 4 | build pythagorasBoxedLazy-cl.out: eval pythagorasBoxedLazy-cl 5 | 6 | build pythagorasBoxedStrict-cl: clean-start pythagorasBoxedStrict.icl 7 | build pythagorasBoxedStrict-cl.out: eval pythagorasBoxedStrict-cl 8 | 9 | build pythagorasUnboxedLazy-cl: clean-start pythagorasUnboxedLazy.icl 10 | build pythagorasUnboxedLazy-cl.out: eval pythagorasUnboxedLazy-cl 11 | 12 | build pythagorasUnboxedStrict-cl: clean-start pythagorasUnboxedStrict.icl 13 | build pythagorasUnboxedStrict-cl.out: eval pythagorasUnboxedStrict-cl 14 | -------------------------------------------------------------------------------- /idris-clean.cabal: -------------------------------------------------------------------------------- 1 | name: idris-clean 2 | version: 0.1.0.0 3 | synopsis: Idris to Clean backend 4 | -- description: 5 | license: MIT 6 | license-file: LICENSE 7 | author: Tim Steenvoorden 8 | maintainer: Tim Steenvoorden 9 | build-type: Simple 10 | cabal-version: >=1.10 11 | 12 | executable idris-codegen-clean 13 | main-is: Main.hs 14 | hs-source-dirs: Sources 15 | other-modules: IRTS.CodegenClean 16 | -- other-extensions: 17 | build-depends: base, filepath, text, wl-pprint-text, idris 18 | default-language: Haskell2010 19 | 20 | ghc-options: -O2 21 | -------------------------------------------------------------------------------- /Benchmarks/sortvec.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import System 4 | import Effects 5 | import Effect.Random 6 | import Data.Vect 7 | 8 | total 9 | insert : Ord a => a -> Vect n a -> Vect (S n) a 10 | insert x [] = [x] 11 | insert x (y :: ys) = if (x < y) then x :: y :: ys else y :: insert x ys 12 | 13 | vsort : Ord a => Vect n a -> Vect n a 14 | vsort [] = [] 15 | vsort (x :: xs) = insert x (vsort xs) 16 | 17 | mkSortVec : (n : Nat) -> Eff (Vect n Int) [RND] 18 | mkSortVec Z = pure [] 19 | mkSortVec (S k) = pure (fromInteger !(rndInt 0 10000) :: !(mkSortVec k)) 20 | 21 | main : IO () 22 | main = do 23 | arg <- getLine 24 | let vec = runPure $ (srand 123456789 *> mkSortVec (fromInteger (cast arg))) 25 | putStrLn "Made vector" 26 | printLn (vsort vec) 27 | -------------------------------------------------------------------------------- /Tests/ReferenceTypeArrays.idr: -------------------------------------------------------------------------------- 1 | {- 2 | foo 3 | bar 4 | baz 5 | qux 6 | quux 7 | -} 8 | 9 | import CIL.FFI 10 | import CIL.FFI.Array 11 | import Data.Vect 12 | 13 | ToCharArray : String -> CIL_IO CharArray 14 | ToCharArray = 15 | invoke (CILInstance "ToCharArray") 16 | (String -> CIL_IO CharArray) 17 | 18 | Split : String -> CharArray -> CIL_IO StringArray 19 | Split = 20 | invoke (CILInstance "Split") 21 | (String -> CharArray -> CIL_IO StringArray) 22 | 23 | putAll : StringArray -> CIL_IO () 24 | putAll ss = forEach_ ss putStrLn 25 | 26 | main : CIL_IO () 27 | main = do 28 | Split "foo,bar baz" !(ToCharArray ", ") >>= putAll 29 | arrayOf CILTyStr ["qux", "quux"] >>= putAll 30 | 31 | -- Local Variables: 32 | -- idris-load-packages: ("cil") 33 | -- End: 34 | -------------------------------------------------------------------------------- /Benchmarks/build.ninja: -------------------------------------------------------------------------------- 1 | include ../rules.ninja 2 | 3 | build fasta-id | fasta.ibc: idris fasta.idr 4 | build fasta.icl: idris-clean fasta.ibc 5 | build fasta-cl: clean fasta.icl 6 | 7 | build pidigits-id | pidigits.ibc: idris pidigits.idr 8 | build pidigits.icl: idris-clean pidigits.ibc 9 | build pidigits-cl: clean pidigits.icl 10 | 11 | # build quasigroups-id | quasigroups.ibc: idris quasigroups.idr 12 | # build quasigroups.icl: idris-clean quasigroups.ibc 13 | # build quasigroups-cl: clean quasigroups.icl 14 | 15 | build sortvec-id | sortvec.ibc: idris sortvec.idr 16 | build sortvec.icl: idris-clean sortvec.ibc 17 | build sortvec-cl: clean sortvec.icl 18 | 19 | build pythagoras-id | pythagoras.ibc: idris pythagoras.idr 20 | build pythagoras.icl: idris-clean pythagoras.ibc 21 | build pythagoras-cl: clean pythagoras.icl 22 | -------------------------------------------------------------------------------- /Benchmarks/Comparisons/pythagorasBoxedLazy.icl: -------------------------------------------------------------------------------- 1 | module pythagorasBoxedLazy 2 | 3 | import StdEnv 4 | 5 | :: List a :== [a] 6 | :: LazyBox a = Box a 7 | 8 | instance + (LazyBox a) | + a where 9 | (+) (Box a) (Box b) = Box (a + b) 10 | instance * (LazyBox a) | * a where 11 | (*) (Box a) (Box b) = Box (a * b) 12 | instance < (LazyBox a) | < a where 13 | (<) (Box a) (Box b) = a < b 14 | instance == (LazyBox a) | == a where 15 | (==) (Box a) (Box b) = a == b 16 | instance one (LazyBox a) | one a where 17 | one = Box (one) 18 | 19 | pythagoras :: (LazyBox Int) -> List (LazyBox Int, LazyBox Int, LazyBox Int) 20 | pythagoras max = [ 21 | (x, y, z) 22 | \\ z <- [Box 1..max] 23 | , y <- [Box 1..z] 24 | , x <- [Box 1..y] 25 | | x * x + y * y == z * z 26 | ] 27 | 28 | Start = pythagoras (Box 300) 29 | -------------------------------------------------------------------------------- /Benchmarks/Comparisons/pythagorasBoxedStrict.icl: -------------------------------------------------------------------------------- 1 | module pythagorasBoxedStrict 2 | 3 | import StdEnv 4 | 5 | :: List a :== [a] 6 | :: StrictBox a = Box !a 7 | 8 | instance + (StrictBox a) | + a where 9 | (+) (Box a) (Box b) = Box (a + b) 10 | instance * (StrictBox a) | * a where 11 | (*) (Box a) (Box b) = Box (a * b) 12 | instance < (StrictBox a) | < a where 13 | (<) (Box a) (Box b) = a < b 14 | instance == (StrictBox a) | == a where 15 | (==) (Box a) (Box b) = a == b 16 | instance one (StrictBox a) | one a where 17 | one = Box (one) 18 | 19 | pythagoras :: (StrictBox Int) -> List (StrictBox Int, StrictBox Int, StrictBox Int) 20 | pythagoras max = [ 21 | (x, y, z) 22 | \\ z <- [Box 1..max] 23 | , y <- [Box 1..z] 24 | , x <- [Box 1..y] 25 | | x * x + y * y == z * z 26 | ] 27 | 28 | Start = pythagoras (Box 300) 29 | -------------------------------------------------------------------------------- /Tests/Bits32.idr: -------------------------------------------------------------------------------- 1 | {- 2 | 00000000 3 | 00000000 4 | 00000000 5 | 00000000 6 | 00000005 7 | 00000010 8 | 00000000 9 | 00000000 10 | 0000000A 11 | 00000000 12 | 00000001 13 | 00000000 14 | 0000000F 15 | 00000010 16 | 00000001 17 | 00000000 18 | 00000014 19 | 00000000 20 | 00000002 21 | 00000000 22 | 00000019 23 | 00000010 24 | 00000002 25 | 00000000 26 | 0000001E 27 | 00000000 28 | 00000003 29 | 00000000 30 | 00000003 31 | 00000011 32 | 00000003 33 | 00000000 34 | 00000008 35 | 00000001 36 | 00000004 37 | 00000000 38 | 0000000D 39 | 00000011 40 | 00000004 41 | 00000000 42 | -} 43 | 44 | mask : Bits32 -> Bits32 -> Bits32 45 | mask lvl hash = prim__andB32 (prim__lshrB32 hash (5 * lvl)) 0x1F 46 | 47 | values : List Bits32 48 | values = do 49 | hash <- prim__zextInt_B32 <$> [0, 517..5099] 50 | lvl <- prim__zextInt_B32 <$> [0, 1, 2, 3] 51 | pure (mask lvl hash) 52 | 53 | main : IO () 54 | main = for_ values printLn 55 | -------------------------------------------------------------------------------- /Tests/ValueTypeProperties.idr: -------------------------------------------------------------------------------- 1 | {- 2 | foo 3 | bar 4 | -} 5 | import CIL.FFI 6 | 7 | ||| System.Collections.DictionaryEntry value type. 8 | DictionaryEntry : Type 9 | DictionaryEntry = CIL $ corlibTyVal "System.Collections.DictionaryEntry" 10 | 11 | IsA Object DictionaryEntry where {} 12 | 13 | newDictionaryEntry : key -> value -> CIL_IO DictionaryEntry 14 | newDictionaryEntry key value = new (Object -> Object -> CIL_IO DictionaryEntry) 15 | (believe_me key) 16 | (believe_me value) 17 | 18 | Key : DictionaryEntry -> CIL_IO Object 19 | Key = invoke (CILInstance "get_Key") (DictionaryEntry -> CIL_IO Object) 20 | 21 | Value : DictionaryEntry -> CIL_IO Object 22 | Value = invoke (CILInstance "get_Value") (DictionaryEntry -> CIL_IO Object) 23 | 24 | main : CIL_IO () 25 | main = do 26 | e <- newDictionaryEntry "foo" "bar" 27 | for_ [Key, Value] $ \p => 28 | putStrLn !(p e >>= ToString) 29 | -------------------------------------------------------------------------------- /Tests/Vector.idr: -------------------------------------------------------------------------------- 1 | {- 2 | True 3 | 0 4 | False 5 | False 6 | 4 7 | 42 8 | 42 9 | True 10 | False 11 | [33, 42, 42, 42, 42] 12 | [42, 42, 33, 42, 42] 13 | [42, 42, 42, 42, 33] 14 | [33, 42, 42, 42] 15 | [42, 42, 33, 42] 16 | [42, 42, 42, 33] 17 | False 18 | True 19 | -} 20 | 21 | import Data.Vector 22 | 23 | main : IO () 24 | main = do 25 | let e = the (Vector Int) empty 26 | printLn (null e) 27 | printLn (length e) 28 | printLn (elem 42 e) 29 | let a = replicate 4 (the Int 42) 30 | printLn (null a) 31 | printLn (length a) 32 | printLn (a !! 0) 33 | printLn (a !! 3) 34 | printLn (elem 42 a) 35 | printLn (elem 33 a) 36 | printLn (unsafeInsertAt 0 33 a) 37 | printLn (unsafeInsertAt 2 33 a) 38 | printLn (unsafeInsertAt (length a) 33 a) 39 | printLn (unsafeReplaceAt 0 33 a) 40 | printLn (unsafeReplaceAt 2 33 a) 41 | printLn (maybe a (\index => unsafeReplaceAt index 33 a) (lastIndex a)) 42 | printLn (elem 33 a) 43 | printLn (elem 33 (singleton 33)) 44 | 45 | -- Local Variables: 46 | -- idris-load-packages: ("cil") 47 | -- End: 48 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Tim Steenvoorden 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Sources/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Idris.Core.TT 4 | import Idris.AbsSyntax 5 | import Idris.ElabDecls 6 | import Idris.REPL 7 | import Idris.Main 8 | import Idris.ModeCommon 9 | 10 | import IRTS.Compiler 11 | import IRTS.CodegenClean 12 | 13 | import System.Environment 14 | import System.Exit 15 | 16 | import Paths_idris_clean 17 | 18 | data Opts = Opts 19 | { inputs :: [FilePath] 20 | , output :: FilePath } 21 | 22 | showUsage = do 23 | putStrLn "Usage: idris-codegen-clean [-o ]" 24 | exitSuccess 25 | 26 | getOpts :: IO Opts 27 | getOpts = do 28 | xs <- getArgs 29 | return $ process (Opts [] "out.icl") xs 30 | where 31 | process opts ("-o":o:xs) = process (opts { output = o }) xs 32 | process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs 33 | process opts [] = opts 34 | 35 | run :: Opts -> Idris () 36 | run opts = do 37 | elabPrims 38 | loadInputs (inputs opts) Nothing 39 | mainProg <- elabMain 40 | ir <- compile (Via IBCFormat "clean") (output opts) (Just mainProg) 41 | runIO $ codegenClean ir 42 | 43 | main :: IO () 44 | main = do 45 | opts <- getOpts 46 | if null (inputs opts) 47 | then showUsage 48 | else runMain (run opts) 49 | -------------------------------------------------------------------------------- /Tests/ValueTypeArrays.idr: -------------------------------------------------------------------------------- 1 | {- 2 | a[0] = {foo: bar} 3 | a[1] = {baz: qux} 4 | -} 5 | import CIL.FFI.Array 6 | import Data.Vect 7 | 8 | DictionaryEntryTy : CILTy 9 | DictionaryEntryTy = corlibTyVal "System.Collections.DictionaryEntry" 10 | 11 | ||| System.Collections.DictionaryEntry value type. 12 | DictionaryEntry : Type 13 | DictionaryEntry = CIL DictionaryEntryTy 14 | 15 | newDictionaryEntry : key -> value -> CIL_IO DictionaryEntry 16 | newDictionaryEntry key value = new (Object -> Object -> CIL_IO DictionaryEntry) 17 | (believe_me key) 18 | (believe_me value) 19 | 20 | Key : DictionaryEntry -> CIL_IO Object 21 | Key = invoke (CILInstance "get_Key") (DictionaryEntry -> CIL_IO Object) 22 | 23 | Value : DictionaryEntry -> CIL_IO Object 24 | Value = invoke (CILInstance "get_Value") (DictionaryEntry -> CIL_IO Object) 25 | 26 | main : CIL_IO () 27 | main = do 28 | a <- arrayOf DictionaryEntryTy [ !(newDictionaryEntry "foo" "bar") 29 | , !(newDictionaryEntry "baz" "qux") ] 30 | for_ [0..1] $ \i => do 31 | e <- get a i 32 | k <- Key e >>= ToString 33 | v <- Value e >>= ToString 34 | putStrLn ("a[" ++ show i ++ "] = {" ++ k ++ ": " ++ v ++ "}") 35 | 36 | -- Local Variables: 37 | -- idris-load-packages: ("cil") 38 | -- End: 39 | -------------------------------------------------------------------------------- /Benchmarks/pidigits.idr: -------------------------------------------------------------------------------- 1 | import System 2 | import Data.Vect 3 | 4 | {- Toy program that outputs the n first digits of Pi. 5 | 6 | Inspired from http://www.haskell.org/haskellwiki/Shootout/Pidigits. 7 | The original ns and str lazy lists have been replaced by strict functions. 8 | 9 | Memory usage seems to be excessive. One of the branches of str is tail recursive, and 10 | the other one only needs to cons an extra Integer. 11 | 12 | For reference, the Haskell version runs in 0m0.230s when printing to /dev/null. 13 | It almost runs in constant space. 14 | -} 15 | 16 | data F = MkF Integer Integer Integer 17 | 18 | -- Prints the list of digits by groups of 10 19 | loop : Nat -> Nat -> List Integer -> IO () 20 | loop n k' Nil = putStrLn $ (pack $ Vect.replicate n ' ') ++ "\t:" ++ show k' 21 | loop Z k' xs = do 22 | putStrLn ("\t:" ++ show k') 23 | loop 10 k' xs 24 | loop (S k) k' (x::xs) = do 25 | putStr (show x) 26 | loop k (S k') xs 27 | 28 | fn : Integer -> F 29 | fn k = MkF k (4*k+2) (2*k+1) 30 | 31 | flr : Integer -> F -> Integer 32 | flr x (MkF q r t) = (q*x + r) `div` t 33 | 34 | comp : F -> F -> F 35 | comp (MkF q r t) (MkF u v x) = MkF (q*u) (q*v + r*x) (t*x) 36 | 37 | -- Returns the list of digits of pi. Memory hungry. 38 | str : F -> Integer -> Nat -> List Integer 39 | str _ _ Z = Nil 40 | str z k (S n) = 41 | if y == flr 4 z 42 | then y :: str (comp (MkF 10 (-10*y) 1) z ) k n 43 | else str (comp z (fn k)) (k+1) (S n) 44 | where y = flr 3 z 45 | 46 | main : IO () 47 | main = do 48 | arg <- getLine 49 | let n = fromInteger (cast arg) 50 | let l = str (MkF 1 0 1) 1 n 51 | loop 10 0 l 52 | pure () 53 | -------------------------------------------------------------------------------- /Tests/Enums.idr: -------------------------------------------------------------------------------- 1 | {- 2 | Read 3 | reading 4 | Write 5 | writing 6 | ReadWrite 7 | writing 8 | -} 9 | module Main 10 | 11 | import CIL.FFI 12 | 13 | {- 14 | 15 | [Flags] 16 | enum System.IO.FileAccess { 17 | Read = 1, 18 | Write = 2, 19 | ReadWrite = Read + Write 20 | } 21 | 22 | -} 23 | 24 | namespace System.IO.FileAccess 25 | 26 | FileAccessTy : CILTy 27 | FileAccessTy = corlibTyVal "System.IO.FileAccess" 28 | 29 | FileAccess : Type 30 | FileAccess = CIL FileAccessTy 31 | 32 | IsA Object FileAccess where {} 33 | 34 | Read : CIL_IO FileAccess 35 | Read = invoke (CILEnumValueOf FileAccessTy "1") 36 | (CIL_IO FileAccess) 37 | 38 | Write : CIL_IO FileAccess 39 | Write = invoke (CILEnumValueOf FileAccessTy "2") 40 | (CIL_IO FileAccess) 41 | 42 | ReadWrite : CIL_IO FileAccess 43 | ReadWrite = invoke (CILEnumValueOf FileAccessTy "3") 44 | (CIL_IO FileAccess) 45 | 46 | namespace System.IO.TFileAccess 47 | 48 | ||| ADT version of `System.IO.FileAccess`. 49 | data TFileAccess = Read 50 | | Write 51 | | ReadWrite 52 | 53 | fromEnum : FileAccess -> CIL_IO TFileAccess 54 | fromEnum e = do 55 | i32 <- ToInt32 e 56 | pure $ 57 | case i32 of 58 | 1 => Read 59 | 2 => Write 60 | _ => ReadWrite 61 | 62 | describe : TFileAccess -> String 63 | describe Read = "reading" 64 | describe _ = "writing" 65 | 66 | testEnumAsObject : FileAccess -> CIL_IO () 67 | testEnumAsObject e = putStrLn !(ToString e) 68 | 69 | testFromEnum : FileAccess -> CIL_IO () 70 | testFromEnum e = putStrLn (describe !(fromEnum e)) 71 | 72 | main : CIL_IO () 73 | main = do 74 | for_ [!Read, !Write, !ReadWrite] $ 75 | \e => do testEnumAsObject e 76 | testFromEnum e 77 | -------------------------------------------------------------------------------- /Tests/HashSet.idr: -------------------------------------------------------------------------------- 1 | {- 2 | 205 3 | [] 4 | True 5 | True 6 | 36 7 | [(1, 5), (1, 6), (2, 5), (2, 6), (11, 5), (11, 6), (11, 7), (12, 4), (12, 8), (13, 3), (13, 9), (14, 3), (14, 9), (15, 6), (16, 4), (16, 8), (17, 5), (17, 6), (17, 7), (18, 6), (21, 3), (21, 4), (21, 5), (22, 3), (22, 4), (22, 5), (23, 2), (23, 6), (25, 1), (25, 2), (25, 6), (25, 7), (35, 3), (35, 4), (36, 3), (36, 4)] 8 | -} 9 | 10 | import Data.HashSet 11 | 12 | %default total 13 | 14 | data CollidingInt = MkCollidingInt Int 15 | 16 | Eq CollidingInt where 17 | (==) (MkCollidingInt i) (MkCollidingInt j) = i == j 18 | 19 | Hash CollidingInt where 20 | hash (MkCollidingInt i) = assert_total (prim__zextInt_B32 (mod i 39)) 21 | 22 | Show CollidingInt where 23 | show (MkCollidingInt i) = show i 24 | 25 | Cell : Type 26 | Cell = (Int, Int) 27 | 28 | Cells : Type 29 | Cells = HashSet Cell 30 | 31 | gosperGun : Cells 32 | gosperGun = fromList 33 | [(1,5), (1,6), (2,5), (2,6), 34 | (11,5), (11,6), (11,7), (12,4), (12,8), 35 | (13,3), (13,9), (14,3), (14,9), (15,6), 36 | (16,4), (16,8), (17,5), (17,6), (17,7), (18,6), 37 | (21,3), (21,4), (21,5), (22,3), (22,4), (22,5), 38 | (23,2), (23,6), (25,1), (25,2), (25,6), (25,7), 39 | (35,3), (36,3), (35,4), (36,4)] 40 | 41 | for : Monad m => HashSet a -> (a -> m b) -> m (List b) 42 | for xs f = foldM (\acc, e => (:: acc) <$> f e) [] xs 43 | 44 | main : IO () 45 | main = do 46 | let keys = MkCollidingInt <$> [0, 5..1024] 47 | let set = foldl (flip insert) (the (HashSet CollidingInt) empty) keys 48 | printLn (length set) 49 | printLn (filter (not . flip member set) keys) 50 | printLn (all (flip member set) keys) 51 | printLn (all (not . flip member set) (MkCollidingInt <$> [1024, 1033..2048])) 52 | 53 | let cells = gosperGun 54 | printLn (length cells) 55 | ls <- for cells pure 56 | printLn (sort ls) 57 | 58 | -- Local Variables: 59 | -- idris-load-packages: ("cil") 60 | -- End: 61 | -------------------------------------------------------------------------------- /Tests/SinglePrimitives.idr: -------------------------------------------------------------------------------- 1 | {- 2 | 0.42 3 | 1.68 4 | 1.34 5 | 0.34 6 | 0.5 < 0.5 => False 7 | 0.5 <= 0.5 => True 8 | 0.5 == 0.5 => True 9 | 0.5 >= 0.5 => True 10 | 0.5 > 0.5 => False 11 | 0.5 compare 0.5 => EQ 12 | 0.5 max 0.5 => 0.5 13 | 0.5 min 0.5 => 0.5 14 | 0.5 < 1 => True 15 | 0.5 <= 1 => True 16 | 0.5 == 1 => False 17 | 0.5 >= 1 => False 18 | 0.5 > 1 => False 19 | 0.5 compare 1 => LT 20 | 0.5 max 1 => 1 21 | 0.5 min 1 => 0.5 22 | 1 < 0.5 => False 23 | 1 <= 0.5 => False 24 | 1 == 0.5 => False 25 | 1 >= 0.5 => True 26 | 1 > 0.5 => True 27 | 1 compare 0.5 => GT 28 | 1 max 0.5 => 1 29 | 1 min 0.5 => 0.5 30 | 1 < 1 => False 31 | 1 <= 1 => True 32 | 1 == 1 => True 33 | 1 >= 1 => True 34 | 1 > 1 => False 35 | 1 compare 1 => EQ 36 | 1 max 1 => 1 37 | 1 min 1 => 1 38 | abs -1 => 1 39 | - (-1) => 1 40 | abs 1 => 1 41 | - (1) => -1 42 | -} 43 | import CIL.FFI.Single 44 | 45 | implementation Show Ordering where 46 | show EQ = "EQ" 47 | show LT = "LT" 48 | show GT = "GT" 49 | 50 | testNum : IO () 51 | testNum = 52 | for_ [(*), (/), (+), (-)] $ \op => 53 | printLn $ single 0.84 `op` single 0.5 54 | 55 | testOrd : IO () 56 | testOrd = traverse_ putStrLn (test singles singles) 57 | where 58 | singles = [ single 0.5, single 1.0 ] 59 | 60 | op : Show r => String -> (Single -> Single -> r) -> (Single -> Single -> String) 61 | op name o = \x, y => show x ++ " " ++ name ++ " " ++ show y ++ " => " ++ show (x `o` y) 62 | 63 | operators : List (Single -> Single -> String) 64 | operators = [ op "<" (<), op "<=" (<=), op "==" (==) 65 | , op ">=" (>=), op ">" (>), op "compare" compare 66 | , op "max" max, op "min" min ] 67 | 68 | test : List Single -> List Single -> List String 69 | test xs ys = do 70 | x <- xs 71 | y <- ys 72 | map (\o => x `o` y) operators 73 | 74 | testNeg : IO () 75 | testNeg = 76 | for_ [ single (-1), single 1 ] $ \x => do 77 | putStrLn $ "abs " ++ show x ++ " => " ++ show (abs x) 78 | putStrLn $ "- (" ++ show x ++ ") => " ++ show (-x) 79 | 80 | main : IO () 81 | main = do 82 | testNum 83 | testOrd 84 | testNeg 85 | 86 | -- Local Variables: 87 | -- idris-load-packages: ("cil") 88 | -- End: 89 | -------------------------------------------------------------------------------- /Tests/Generics.idr: -------------------------------------------------------------------------------- 1 | {- 2 | (1, 1) 3 | System.Collections.Generic.HashSet`1[System.Tuple`2[System.Int32,System.Int32]] 4 | True 5 | False 6 | True 7 | False 8 | -} 9 | 10 | import CIL.FFI 11 | 12 | TupleTy : CILTy 13 | TupleTy = corlibTy "System.Tuple" 14 | 15 | IntTupleTy : CILTy 16 | IntTupleTy = CILTyGen TupleTy [CILTyInt32, CILTyInt32] 17 | 18 | IntTuple : Type 19 | IntTuple = CIL IntTupleTy 20 | 21 | IsA Object IntTuple where {} 22 | 23 | CreateIntTuple : Int -> Int -> CIL_IO IntTuple 24 | CreateIntTuple = 25 | invoke (CILCall (CILGenMethod CCCStatic TupleTy "Create" [CILTyInt32, CILTyInt32] 26 | [CILTyGenMethodParam "0", CILTyGenMethodParam "1"] 27 | (CILTyGen TupleTy [CILTyGenMethodParam "0", CILTyGenMethodParam "1"]))) 28 | (Int -> Int -> CIL_IO IntTuple) 29 | 30 | 31 | systemCollectionsTy : String -> CILTy 32 | systemCollectionsTy = CILTyRef "System.Collections" 33 | 34 | HashSetTy : CILTy 35 | HashSetTy = systemCollectionsTy "System.Collections.Generic.HashSet" 36 | 37 | IntTupleHashSet : Type 38 | IntTupleHashSet = CIL (CILTyGen HashSetTy [IntTupleTy]) 39 | 40 | IsA Object IntTupleHashSet where {} 41 | 42 | Add : IntTupleHashSet -> IntTuple -> CIL_IO Bool 43 | Add = 44 | invoke (CILInstanceCustom "Add" [CILTyGenParam "0"] CILTyBool) 45 | (IntTupleHashSet -> IntTuple -> CIL_IO Bool) 46 | 47 | 48 | Contains : IntTupleHashSet -> IntTuple -> CIL_IO Bool 49 | Contains = 50 | invoke (CILInstanceCustom "Contains" [CILTyGenParam "0"] CILTyBool) 51 | (IntTupleHashSet -> IntTuple -> CIL_IO Bool) 52 | 53 | AssemblyReferences : CIL_IO () 54 | AssemblyReferences = 55 | assemblyRef "System.Collections" "4.0.10.0" "B0 3F 5F 7F 11 D5 0A 3A" 56 | 57 | main : CIL_IO () 58 | main = do 59 | AssemblyReferences 60 | CreateIntTuple 1 1 >>= ToString >>= putStrLn 61 | set <- new (CIL_IO IntTupleHashSet) 62 | ToString set >>= putStrLn 63 | CreateIntTuple 1 1 >>= Add set >>= printLn 64 | CreateIntTuple 1 1 >>= Add set >>= printLn 65 | CreateIntTuple 1 1 >>= Contains set >>= printLn 66 | CreateIntTuple 1 2 >>= Contains set >>= printLn 67 | 68 | -- Local Variables: 69 | -- idris-load-packages: ("cil") 70 | -- End: 71 | -------------------------------------------------------------------------------- /Tests/Strings.idr: -------------------------------------------------------------------------------- 1 | {- 2 | False 3 | foobar 4 | oof 5 | rab 6 | True 7 | foofoo 8 | oof 9 | oof 10 | (Hello) 11 | () 12 | ( Idris) 13 | (s) 14 | (s!) 15 | 'I' 16 | 'd' 17 | 'r' 18 | 'i' 19 | 's' 20 | "foo" < "foo" => False 21 | "foo" <= "foo" => True 22 | "foo" == "foo" => True 23 | "foo" >= "foo" => True 24 | "foo" > "foo" => False 25 | "foo" max "foo" => "foo" 26 | "foo" min "foo" => "foo" 27 | "foo" < "bar" => False 28 | "foo" <= "bar" => False 29 | "foo" == "bar" => False 30 | "foo" >= "bar" => True 31 | "foo" > "bar" => True 32 | "foo" max "bar" => "foo" 33 | "foo" min "bar" => "bar" 34 | "bar" < "foo" => True 35 | "bar" <= "foo" => True 36 | "bar" == "foo" => False 37 | "bar" >= "foo" => False 38 | "bar" > "foo" => False 39 | "bar" max "foo" => "foo" 40 | "bar" min "foo" => "bar" 41 | "bar" < "bar" => False 42 | "bar" <= "bar" => True 43 | "bar" == "bar" => True 44 | "bar" >= "bar" => True 45 | "bar" > "bar" => False 46 | "bar" max "bar" => "bar" 47 | "bar" min "bar" => "bar" 48 | -} 49 | module Main 50 | 51 | test : String -> String -> IO () 52 | test s1 s2 = do printLn $ s1 == s2 53 | putStrLn $ s1 ++ s2 54 | for_ [s1, s2] $ putStrLn . reverse 55 | 56 | testSubstr : (Nat, Nat) -> IO () 57 | testSubstr (index, length) = putStrLn $ "(" ++ (substr index length "Hello, Idris!") ++ ")" 58 | 59 | testOrd : IO () 60 | testOrd = traverse_ putStrLn (test strings strings) 61 | where 62 | strings = [ "foo", "bar" ] 63 | 64 | op : Show r => String -> (String -> String -> r) -> (String -> String -> String) 65 | op name o = \x, y => show x ++ " " ++ name ++ " " ++ show y ++ " => " ++ show (x `o` y) 66 | 67 | operators : List (String -> String -> String) 68 | operators = [ op "<" (<), op "<=" (<=), op "==" (==) 69 | , op ">=" (>=), op ">" (>) 70 | , op "max" max, op "min" min ] 71 | 72 | test : List String -> List String -> List String 73 | test xs ys = do 74 | x <- xs 75 | y <- ys 76 | map (\o => x `o` y) operators 77 | 78 | 79 | main : IO () 80 | main = do 81 | test "foo" "bar" 82 | test "foo" "foo" 83 | traverse_ testSubstr [(0, 5), (20, 5), (6, 6), (11, 1), (11, 5)] 84 | traverse_ (putStrLn . show . strIndex "Idris") [0..4] 85 | testOrd 86 | -------------------------------------------------------------------------------- /Tests/Delegates.idr: -------------------------------------------------------------------------------- 1 | {- 2 | before thread 3 | in thread 4 | after thread 5 | True 6 | False 7 | >> True 8 | >> False 9 | -} 10 | module Main 11 | 12 | import CIL.FFI 13 | 14 | Thread : Type 15 | Thread = corlib "System.Threading.Thread" 16 | 17 | %inline 18 | invokeThread : String -> Thread -> CIL_IO () 19 | invokeThread fn = invoke (CILInstance fn) 20 | (Thread -> CIL_IO ()) 21 | 22 | Start : Thread -> CIL_IO () 23 | Start = invokeThread "Start" 24 | 25 | Join : Thread -> CIL_IO () 26 | Join = invokeThread "Join" 27 | 28 | ThreadStartTy : CILTy 29 | ThreadStartTy = corlibTy "System.Threading.ThreadStart" 30 | 31 | ThreadStart : Type 32 | ThreadStart = CilFn ThreadStartTy (CIL_IO ()) 33 | 34 | %inline 35 | BoolToStringTy : CILTy 36 | BoolToStringTy = CILTyGen (corlibTy "System.Func") [CILTyBool, CILTyStr] 37 | 38 | BoolToString : Type 39 | BoolToString = CilFn BoolToStringTy (Bool -> String) 40 | 41 | %inline 42 | Invoke : BoolToString -> Bool -> CIL_IO String 43 | Invoke = invoke (CILInstanceCustom "Invoke" [CILTyGenParam "0"] (CILTyGenParam "1")) 44 | (BoolToString -> Bool -> CIL_IO String) 45 | 46 | boolToString : Bool -> String 47 | boolToString = show 48 | 49 | testBoolToString : BoolToString -> CIL_IO () 50 | testBoolToString bts = 51 | for_ [True, False] $ \b => 52 | Invoke bts b >>= putStrLn 53 | 54 | threadMain : CIL_IO () 55 | threadMain = putStrLn "in thread" 56 | 57 | startThread : CIL_IO () -> CIL_IO Thread 58 | startThread f = do 59 | ts <- delegate ThreadStartTy (CIL_IO ()) f 60 | new (ThreadStart -> CIL_IO Thread) ts 61 | 62 | main : CIL_IO () 63 | main = do 64 | -- And now for something completely different... Threads! 65 | t <- startThread threadMain 66 | putStrLn "before thread" 67 | Start t; Join t 68 | putStrLn "after thread" 69 | 70 | bts <- delegate BoolToStringTy (Bool -> String) boolToString 71 | testBoolToString bts 72 | 73 | -- new String ('>', 2) 74 | prefix <- new (Char -> Int -> CIL_IO String) '>' 2 -- using FFI to avoid inlining into the lambda below 75 | let lambda = \b => prefix ++ " " ++ show b 76 | bts <- delegate BoolToStringTy (Bool -> String) lambda 77 | testBoolToString bts 78 | 79 | -- Local Variables: 80 | -- idris-load-packages: ("cil") 81 | -- End: 82 | -------------------------------------------------------------------------------- /Benchmarks/fasta.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import System 4 | 5 | alu : String 6 | alu = "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG\ 7 | \TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG\ 8 | \CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC\ 9 | \GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA" 10 | 11 | iub : List (Char, Double) 12 | iub = [('a',0.27),('c',0.12),('g',0.12),('t',0.27),('B',0.02) 13 | ,('D',0.02),('H',0.02),('K',0.02),('M',0.02),('N',0.02) 14 | ,('R',0.02),('S',0.02),('V',0.02),('W',0.02),('Y',0.02)] 15 | 16 | homosapiens : List (Char, Double) 17 | homosapiens = [('a',0.3029549426680),('c',0.1979883004921) 18 | ,('g',0.1975473066391),('t',0.3015094502008)] 19 | 20 | 21 | takeRepeat : Int -> String -> String 22 | takeRepeat n s = if n > m 23 | then s ++ takeRepeat (n-m) s 24 | else pack $ take (cast n) $ unpack s 25 | where 26 | m = cast $ length s 27 | 28 | splitAt' : Nat -> String -> (String, String) 29 | splitAt' n s = let s' = unpack s in (pack $ take n s', pack $ drop n s') 30 | 31 | writeAlu : String -> String -> IO () 32 | writeAlu name s0 = putStrLn name *> go s0 33 | where 34 | go "" = pure () 35 | go s = let (h,t) = splitAt' 60 s in putStrLn h *> go t 36 | 37 | replicate : Int -> Char -> String 38 | replicate 0 c = "" 39 | replicate n c = singleton c <+> replicate (n-1) c 40 | 41 | -- scanl : (f : acc -> a -> acc) -> acc -> List a -> List acc 42 | -- scanl f q ls = q :: (case ls of 43 | -- [] => [] 44 | -- x::xs => scanl f (f q x) xs) 45 | 46 | accum : (Char,Double) -> (Char,Double) -> (Char,Double) 47 | accum (_,p) (c,q) = (c,p+q) 48 | 49 | make : String -> Int -> List (Char, Double) -> Int -> IO Int 50 | make name n0 tbl seed0 = do 51 | putStrLn name 52 | make' n0 0 seed0 "" 53 | where 54 | modulus : Int 55 | modulus = 139968 56 | 57 | fill : List (Char,Double) -> Int -> List String 58 | fill ((c,p) :: cps) j = 59 | let k = min modulus (cast (cast modulus * p + 1)) 60 | in replicate (k - j) c :: fill cps k 61 | fill _ _ = [] 62 | 63 | lookupTable : String 64 | lookupTable = Foldable.concat (fill (scanl accum ('a',0) tbl) 0) 65 | 66 | make' : Int -> Int -> Int -> String -> IO Int 67 | make' 0 col seed buf = when (col > 0) (putStrLn buf) *> pure seed 68 | make' n col seed buf = do 69 | let newseed = modInt (seed * 3877 + 29573) modulus 70 | let nextchar = strIndex lookupTable newseed 71 | let newbuf = buf <+> singleton nextchar 72 | if col+1 >= 60 73 | then putStrLn newbuf *> make' (n-1) 0 newseed "" 74 | else make' (n-1) (col+1) newseed newbuf 75 | 76 | 77 | main : IO () 78 | main = do 79 | (_ :: n :: _) <- getArgs 80 | writeAlu ">ONE Homo sapiens alu" (takeRepeat (fromInteger (cast n)*2) alu) 81 | nseed <- make ">TWO IUB ambiguity codes" (fromInteger (cast n)*3) iub 42 82 | make ">THREE Homo sapiens frequency" (fromInteger (cast n)*5) homosapiens nseed 83 | pure () 84 | -------------------------------------------------------------------------------- /Libraries/StdPointer.dcl: -------------------------------------------------------------------------------- 1 | system module StdPointer 2 | /** 3 | * Low level reading from and writing to memory using pointers and offsets. 4 | * 5 | * WARNING: 6 | * This module provides unsafe and impure functions that can really mess up 7 | * your program when used incorrectly. 8 | * Only use these if you understand the risks of these low-level operations. 9 | */ 10 | 11 | :: Pointer :== Int 12 | :: Offset :== Int 13 | 14 | /** 15 | * Read an integer (32 or 64 bits) 16 | */ 17 | readInt :: !Pointer !Offset -> Int 18 | readIntP :: !Pointer !Offset -> (!Int,!Pointer) 19 | readIntElemOffset :: !Pointer !Offset -> Int 20 | readIntElemOffsetP :: !Pointer !Offset -> (!Int,!Pointer) 21 | /** 22 | * Read an integer (32 bits) zero extended 23 | */ 24 | readInt32Z :: !Pointer !Offset -> Int 25 | /** 26 | * Read an integer (32 bits) sign extended 27 | */ 28 | readInt32S :: !Pointer !Offset -> Int 29 | /** 30 | * Read a word (16 bits) zero extended 31 | */ 32 | readInt16Z :: !Pointer !Offset -> Int 33 | /** 34 | * Read a word (16 bits) sign extended 35 | */ 36 | readInt16S :: !Pointer !Offset -> Int 37 | /** 38 | * Read a byte (8 bits) zero extended 39 | */ 40 | readInt8Z :: !Pointer !Offset -> Int 41 | /** 42 | * Read a byte (8 bits) sign extended 43 | */ 44 | readInt8S :: !Pointer !Offset -> Int 45 | /** 46 | * Read a char 47 | */ 48 | readChar :: !Pointer !Offset -> Char 49 | /** 50 | * Read a real (8 bytes) 51 | */ 52 | readReal64 :: !Pointer !Offset -> Real 53 | /** 54 | * Read a real (4 bytes) 55 | */ 56 | readReal32 :: !Pointer !Offset -> Real 57 | 58 | /** 59 | * Write an integer (32 or 64 bits) 60 | */ 61 | writeInt :: !Pointer !Offset !Int -> Pointer 62 | writeIntElemOffset :: !Pointer !Offset !Int -> Pointer 63 | /** 64 | * Write an integer (32 bits) 65 | */ 66 | writeInt32 :: !Pointer !Offset !Int -> Pointer 67 | /** 68 | * Write a word (16 bits) 69 | */ 70 | writeInt16 :: !Pointer !Offset !Int -> Pointer 71 | /** 72 | * Write a word (8 bits) 73 | */ 74 | writeInt8 :: !Pointer !Offset !Int -> Pointer 75 | /** 76 | * Write a char 77 | */ 78 | writeChar :: !Pointer !Offset !Char -> Pointer 79 | /** 80 | * Write a real (8 bytes) 81 | */ 82 | writeReal64 :: !Pointer !Offset !Real -> Pointer 83 | /** 84 | * Write a real (4 bytes) 85 | */ 86 | writeReal32 :: !Pointer !Offset !Real -> Pointer 87 | 88 | //Utility functions 89 | 90 | /** 91 | * Reads the integer located at the pointer 92 | */ 93 | derefInt :: !Pointer -> Int 94 | /** 95 | * Reads the NULL-terminated C-string indicated by the pointer and 96 | * converts it to a normal (not NULL-terminated) Clean-string 97 | */ 98 | derefString :: !Pointer -> String 99 | /** 100 | * Reads the array with given length indicated by the pointer. 101 | */ 102 | derefCharArray :: !Pointer !Int -> {#Char} 103 | /** 104 | * Writes Clean char array to given pointer. 105 | */ 106 | writeCharArray :: !Pointer !{#Char} -> Pointer 107 | /** 108 | * Wraps an integer in an array to enable passing a pointer instead 109 | * of a value to a ccall. 110 | */ 111 | packInt :: !Int -> {#Int} 112 | /** 113 | * Wraps a Clean-string as a NULL-terminated C-string to enable passing 114 | * a pointer to a ccall using the C conventions. 115 | */ 116 | packString :: !String -> {#Char} 117 | /** 118 | * Unpacks a NULL-terminated C-string into a Clean-string. 119 | */ 120 | unpackString :: !{#Char} -> String 121 | /** 122 | * Unpacks a 64-bit integer from a byte array 123 | */ 124 | unpackInt64 :: !{#Char} !Offset -> Int 125 | /** 126 | * Unpacks a 32-bit integer from a byte array (zero extended on 64-bit) 127 | */ 128 | unpackInt32Z :: !{#Char} !Offset -> Int 129 | /** 130 | * Unpacks a 32-bit integer from a byte array (sign extended on 64-bit) 131 | */ 132 | unpackInt32S :: !{#Char} !Offset -> Int 133 | /** 134 | * Unpacks a 16-bit integer from a byte array (zero extended on 32-bit and 64-bit) 135 | */ 136 | unpackInt16Z :: !{#Char} !Offset -> Int 137 | /* 138 | * Unpacks a 16-bit integer from a byte array (sign extended on 32-bit and 64-bit) 139 | */ 140 | unpackInt16S :: !{#Char} !Offset -> Int 141 | /** 142 | * Unpacks a boolean from a byte array 143 | */ 144 | unpackBool :: !{#Char} !Offset -> Bool 145 | 146 | forceEval :: !a !*env -> *env 147 | forceEvalPointer :: !Pointer !*env -> *env 148 | 149 | /** 150 | * Global argc pointer 151 | */ 152 | global_argc :: Pointer 153 | /** 154 | * Global argv pointer 155 | */ 156 | global_argv :: Pointer 157 | -------------------------------------------------------------------------------- /Tests/build.ninja: -------------------------------------------------------------------------------- 1 | include ../rules.ninja 2 | 3 | build Bits32-id | Bits32.ibc: idris Bits32.idr 4 | build Bits32.icl: idris-clean Bits32.ibc 5 | build Bits32-cl: clean Bits32.icl 6 | build Bits32-id.out: eval Bits32-id 7 | build Bits32-cl.out: eval Bits32-cl 8 | build Bits32-test: diff Bits32-id.out Bits32-cl.out 9 | 10 | build Chars-id | Chars.ibc: idris Chars.idr 11 | build Chars.icl: idris-clean Chars.ibc 12 | build Chars-cl: clean Chars.icl 13 | build Chars-id.out: eval Chars-id 14 | build Chars-cl.out: eval Chars-cl 15 | build Chars-test: diff Chars-id.out Chars-cl.out 16 | 17 | build Data-id | Data.ibc: idris Data.idr 18 | build Data.icl: idris-clean Data.ibc 19 | build Data-cl: clean Data.icl 20 | build Data-id.out: eval Data-id 21 | build Data-cl.out: eval Data-cl 22 | build Data-test: diff Data-id.out Data-cl.out 23 | 24 | # build Delegates-id | Delegates.ibc: idris Delegates.idr 25 | # build Delegates.icl: idris-clean Delegates.ibc 26 | # build Delegates-cl: clean Delegates.icl 27 | 28 | build Doubles-id | Doubles.ibc: idris Doubles.idr 29 | build Doubles.icl: idris-clean Doubles.ibc 30 | build Doubles-cl: clean Doubles.icl 31 | build Doubles-id.out: eval Doubles-id 32 | build Doubles-cl.out: eval Doubles-cl 33 | build Doubles-test: diff Doubles-id.out Doubles-cl.out 34 | 35 | # build EffectsTest-id | EffectsTest.ibc: idris EffectsTest.idr 36 | # build EffectsTest.icl: idris-clean EffectsTest.ibc 37 | # build EffectsTest-cl: clean EffectsTest.icl 38 | 39 | # build Enums-id | Enums.ibc: idris Enums.idr 40 | # build Enums.icl: idris-clean Enums.ibc 41 | # build Enums-cl: clean Enums.icl 42 | 43 | # build FFI-id | FFI.ibc: idris FFI.idr 44 | # build FFI.icl: idris-clean FFI.ibc 45 | # build FFI-cl: clean FFI.icl 46 | 47 | build Foldables-id | Foldables.ibc: idris Foldables.idr 48 | build Foldables.icl: idris-clean Foldables.ibc 49 | build Foldables-cl: clean Foldables.icl 50 | build Foldables-id.out: eval Foldables-id 51 | build Foldables-cl.out: eval Foldables-cl 52 | build Foldables-test: diff Foldables-id.out Foldables-cl.out 53 | 54 | # build Generics-id | Generics.ibc: idris Generics.idr 55 | # build Generics.icl: idris-clean Generics.ibc 56 | # build Generics-cl: clean Generics.icl 57 | 58 | # build HashSet-id | HashSet.ibc: idris HashSet.idr 59 | # build HashSet.icl: idris-clean HashSet.ibc 60 | # build HashSet-cl: clean HashSet.icl 61 | 62 | build HelloWorld-id | HelloWorld.ibc: idris HelloWorld.idr 63 | build HelloWorld.icl: idris-clean HelloWorld.ibc 64 | build HelloWorld-cl: clean HelloWorld.icl 65 | build HelloWorld-id.out: eval HelloWorld-id 66 | build HelloWorld-cl.out: eval HelloWorld-cl 67 | build HelloWorld-test: diff HelloWorld-id.out HelloWorld-cl.out 68 | 69 | build IfThenElse-id | IfThenElse.ibc: idris IfThenElse.idr 70 | build IfThenElse.icl: idris-clean IfThenElse.ibc 71 | build IfThenElse-cl: clean IfThenElse.icl 72 | build IfThenElse-id.out: eval IfThenElse-id 73 | build IfThenElse-cl.out: eval IfThenElse-cl 74 | build IfThenElse-test: diff IfThenElse-id.out IfThenElse-cl.out 75 | 76 | build Ints-id | Ints.ibc: idris Ints.idr 77 | build Ints.icl: idris-clean Ints.ibc 78 | build Ints-cl: clean Ints.icl 79 | build Ints-id.out: eval Ints-id 80 | build Ints-cl.out: eval Ints-cl 81 | build Ints-test: diff Ints-id.out Ints-cl.out 82 | 83 | build Lists-id | Lists.ibc: idris Lists.idr 84 | build Lists.icl: idris-clean Lists.ibc 85 | build Lists-cl: clean Lists.icl 86 | build Lists-id.out: eval Lists-id 87 | build Lists-cl.out: eval Lists-cl 88 | build Lists-test: diff Lists-id.out Lists-cl.out 89 | 90 | # build Nullable-id | Nullable.ibc: idris Nullable.idr 91 | # build Nullable.icl: idris-clean Nullable.ibc 92 | # build Nullable-cl: clean Nullable.icl 93 | 94 | # build PrimitiveArrays-id | PrimitiveArrays.ibc: idris PrimitiveArrays.idr 95 | # build PrimitiveArrays.icl: idris-clean PrimitiveArrays.ibc 96 | # build PrimitiveArrays-cl: clean PrimitiveArrays.icl 97 | 98 | build Records-id | Records.ibc: idris Records.idr 99 | build Records.icl: idris-clean Records.ibc 100 | build Records-cl: clean Records.icl 101 | build Records-id.out: eval Records-id 102 | build Records-cl.out: eval Records-cl 103 | build Records-test: diff Records-id.out Records-cl.out 104 | 105 | # build ReferenceTypeArrays-id | ReferenceTypeArrays.ibc: idris ReferenceTypeArrays.idr 106 | # build ReferenceTypeArrays.icl: idris-clean ReferenceTypeArrays.ibc 107 | # build ReferenceTypeArrays-cl: clean ReferenceTypeArrays.icl 108 | 109 | build Show-id | Show.ibc: idris Show.idr 110 | build Show.icl: idris-clean Show.ibc 111 | build Show-cl: clean Show.icl 112 | build Show-id.out: eval Show-id 113 | build Show-cl.out: eval Show-cl 114 | build Show-test: diff Show-id.out Show-cl.out 115 | 116 | # build SinglePrimitives-id | SinglePrimitives.ibc: idris SinglePrimitives.idr 117 | # build SinglePrimitives.icl: idris-clean SinglePrimitives.ibc 118 | # build SinglePrimitives-cl: clean SinglePrimitives.icl 119 | 120 | build SortedSet-id | SortedSet.ibc: idris SortedSet.idr 121 | build SortedSet.icl: idris-clean SortedSet.ibc 122 | build SortedSet-cl: clean SortedSet.icl 123 | build SortedSet-id.out: eval SortedSet-id 124 | build SortedSet-cl.out: eval SortedSet-cl 125 | build SortedSet-test: diff SortedSet-id.out SortedSet-cl.out 126 | 127 | build Streams-id | Streams.ibc: idris Streams.idr 128 | build Streams.icl: idris-clean Streams.ibc 129 | build Streams-cl: clean Streams.icl 130 | # build Streams-id.out: eval Streams-id 131 | # build Streams-cl.out: eval Streams-cl 132 | # build Streams-test: diff Streams-id.out Streams-cl.out 133 | 134 | build Strings-id | Strings.ibc: idris Strings.idr 135 | build Strings.icl: idris-clean Strings.ibc 136 | build Strings-cl: clean Strings.icl 137 | build Strings-id.out: eval Strings-id 138 | build Strings-cl.out: eval Strings-cl 139 | build Strings-test: diff Strings-id.out Strings-cl.out 140 | 141 | build StrInt-id | StrInt.ibc: idris StrInt.idr 142 | build StrInt.icl: idris-clean StrInt.ibc 143 | build StrInt-cl: clean StrInt.icl 144 | build StrInt-id.out: eval StrInt-id 145 | build StrInt-cl.out: eval StrInt-cl 146 | build StrInt-test: diff StrInt-id.out StrInt-cl.out 147 | 148 | # build ValueTypeArrays-id | ValueTypeArrays.ibc: idris ValueTypeArrays.idr 149 | # build ValueTypeArrays.icl: idris-clean ValueTypeArrays.ibc 150 | # build ValueTypeArrays-cl: clean ValueTypeArrays.icl 151 | 152 | # build ValueTypeProperties-id | ValueTypeProperties.ibc: idris ValueTypeProperties.idr 153 | # build ValueTypeProperties.icl: idris-clean ValueTypeProperties.ibc 154 | # build ValueTypeProperties-cl: clean ValueTypeProperties.icl 155 | 156 | # build Vector-id | Vector.ibc: idris Vector.idr 157 | # build Vector.icl: idris-clean Vector.ibc 158 | # build Vector-cl: clean Vector.icl 159 | -------------------------------------------------------------------------------- /Tests/FFI.idr: -------------------------------------------------------------------------------- 1 | {- 2 | 42 3 | 4.2 4 | it works! 5 | True 6 | 00000000-0000-0000-0000-000000000000 7 | VoidFunction : Void 8 | exportedBoolToString : (p0 : Boolean) -> String 9 | printMethod : (t : Type) -> (n : String) -> Void 10 | take5 : (defaultValue : String) -> (flag : Boolean) -> (c : Char) -> (i : Int32) -> (d : Double) -> String 11 | before exportedVoidIO 12 | exported! 13 | after exportedVoidIO 14 | exportedBoolToStringIO True 15 | exportedBoolToStringIO => True 16 | Alan Kay 17 | Kay, Alan 18 | 3 19 | -} 20 | 21 | module Main 22 | 23 | import CIL.System.Reflection 24 | import Data.Vect 25 | 26 | %inline 27 | SystemMathMax : CILForeign 28 | SystemMathMax = CILStatic (CILTyRef "mscorlib" "System.Math") "Max" 29 | 30 | namespace System.Math.Int32 31 | Max : Int -> Int -> CIL_IO Int 32 | Max = invoke SystemMathMax (Int -> Int -> CIL_IO Int) 33 | 34 | namespace System.Math.Double 35 | Max : Double -> Double -> CIL_IO Double 36 | Max = invoke SystemMathMax (Double -> Double -> CIL_IO Double) 37 | 38 | namespace System.Text 39 | StringBuilder : Type 40 | StringBuilder = corlib "System.Text.StringBuilder" 41 | 42 | implementation IsA Object StringBuilder where {} 43 | 44 | %inline 45 | invokeStringBuilder : String -> StringBuilder -> String -> CIL_IO StringBuilder 46 | invokeStringBuilder fn = invoke (CILInstance fn) (StringBuilder -> String -> CIL_IO StringBuilder) 47 | 48 | Append : StringBuilder -> String -> CIL_IO StringBuilder 49 | Append = invokeStringBuilder "Append" 50 | 51 | AppendLine : StringBuilder -> String -> CIL_IO StringBuilder 52 | AppendLine = invokeStringBuilder "AppendLine" 53 | 54 | 55 | GuidTy : CILTy 56 | GuidTy = corlibTyVal "System.Guid" 57 | 58 | Guid : Type 59 | Guid = CIL $ GuidTy 60 | 61 | implementation IsA Object Guid where {} 62 | 63 | NewGuid : CIL_IO Guid 64 | NewGuid = 65 | invoke (CILStatic GuidTy "NewGuid") 66 | (CIL_IO Guid) 67 | 68 | ParseGuid : String -> CIL_IO Guid 69 | ParseGuid = 70 | invoke (CILStatic GuidTy "Parse") 71 | (String -> CIL_IO Guid) 72 | 73 | EmptyGuid : CIL_IO Guid 74 | EmptyGuid = 75 | invoke (CILStaticField GuidTy "Empty") 76 | (CIL_IO Guid) 77 | 78 | %inline 79 | objectArrayFor : Vect _ Object -> CIL_IO ObjectArray 80 | objectArrayFor xs = arrayOf CILTyObj xs 81 | 82 | testValueType : CIL_IO () 83 | testValueType = do 84 | guid <- NewGuid 85 | guid' <- ParseGuid !(ToString guid) 86 | printLn !(Equals guid guid') 87 | ToString !EmptyGuid >>= putStrLn 88 | 89 | invokeStaticMethod : RuntimeType -> String -> Nullable ObjectArray -> CIL_IO (Maybe Object) 90 | invokeStaticMethod type methodName args = 91 | nullable (pure Nothing) (\method => Just <$> Invoke method null args) !(type `GetMethod` methodName) 92 | 93 | testExportedVoidFunction : RuntimeType -> CIL_IO () 94 | testExportedVoidFunction type = do 95 | putStrLn "before exportedVoidIO" 96 | invokeStaticMethod type "VoidFunction" null 97 | putStrLn "after exportedVoidIO" 98 | 99 | testExportedBoolToStringIO : RuntimeType -> CIL_IO () 100 | testExportedBoolToStringIO type = do 101 | ret <- invokeStaticMethod type "exportedBoolToStringIO" (asNullable !(objectArrayFor [asObject True])) 102 | retString <- maybe (pure "ERROR") ToString ret 103 | putStrLn $ "exportedBoolToStringIO => " ++ retString 104 | 105 | record Person where 106 | constructor MkPerson 107 | firstName, lastName : String 108 | 109 | -- And now for something completely different... 110 | -- Let's use the IMPORTING FFI to test the EXPORTING FFI 111 | 112 | ||| Descriptor for the type hosting all exported functions. 113 | TheExportsTy : CILTy 114 | TheExportsTy = CILTyRef "" "TheExports" 115 | 116 | ||| The foreign view of the exported type Person 117 | ||| is a struct with a single field `ptr`. 118 | ExportedPerson : Type 119 | ExportedPerson = CIL $ CILTyVal "" "Person" 120 | 121 | ||| Converts a foreign reference to an exported data type 122 | ||| into its internal representation. 123 | unForeign : ExportedPerson -> CIL_IO Person 124 | unForeign ep = do 125 | ptr <- invoke (CILInstanceField "ptr") (ExportedPerson -> CIL_IO Ptr) ep 126 | pure $ believe_me ptr 127 | 128 | ||| Invokes the exported function `createPerson` via the FFI. 129 | invokeCreatePerson : String -> String -> CIL_IO ExportedPerson 130 | invokeCreatePerson = 131 | invoke (CILStatic TheExportsTy "createPerson") 132 | (String -> String -> CIL_IO ExportedPerson) 133 | 134 | %inline 135 | invokeAccessor : String -> ExportedPerson -> CIL_IO String 136 | invokeAccessor n = 137 | invoke (CILStatic TheExportsTy n) 138 | (ExportedPerson -> CIL_IO String) 139 | 140 | testExportedRecord : CIL_IO () 141 | testExportedRecord = do 142 | -- exercise the foreign view of the record 143 | ep <- invokeCreatePerson "Alan" "Kay" 144 | putStrLn $ !(invokeAccessor "firstName" ep) ++ " " ++ !(invokeAccessor "lastName" ep) 145 | -- internal view should work just the same 146 | p <- unForeign ep 147 | putStrLn $ lastName p ++ ", " ++ firstName p 148 | 149 | testOverloadedStaticMethod : CIL_IO () 150 | testOverloadedStaticMethod = do 151 | Max (the Int 42) (the Int 1) >>= printLn 152 | Max 4.2 1.0 >>= printLn 153 | 154 | testInstanceMethods : CIL_IO () 155 | testInstanceMethods = do 156 | sb <- new (CIL_IO StringBuilder) 157 | Append sb "it " 158 | AppendLine sb "works!" 159 | ToString sb >>= Write 160 | 161 | showParameter : ParameterInfo -> CIL_IO String 162 | showParameter p = do 163 | n <- get_Name p 164 | t <- get_ParameterType p >>= get_Name 165 | pure $ "(" ++ n ++ " : " ++ t ++ ")" 166 | 167 | showMethod : MethodInfo -> CIL_IO String 168 | showMethod m = do 169 | name <- get_Name m 170 | ps <- foldr (\p, acc => (:: acc) <$> showParameter p) (the (List _) []) !(GetParameters m) 171 | ret <- get_ReturnType m >>= get_Name 172 | let sig = ps ++ [ret] 173 | pure $ name ++ " : " ++ (concat . intersperse " -> " $ sig) 174 | 175 | printMethod : RuntimeType -> String -> CIL_IO () 176 | printMethod t n = do 177 | m <- t `GetMethod` n 178 | nullable (pure "method not found") showMethod m >>= putStrLn 179 | 180 | testBoxingUnboxing : RuntimeType -> CIL_IO () 181 | testBoxingUnboxing type = do 182 | ret <- invokeStaticMethod type "exportedIncInt" (asNullable !(objectArrayFor [asObject 2])) 183 | maybe (pure "ERROR") ToString ret >>= putStrLn 184 | 185 | main : CIL_IO () 186 | main = do 187 | testOverloadedStaticMethod 188 | testInstanceMethods 189 | testValueType 190 | 191 | asm <- GetExecutingAssembly 192 | type <- GetType asm "TheExports" True 193 | for_ (the (List _) ["VoidFunction", "exportedBoolToString", "printMethod", "take5"]) $ 194 | printMethod type 195 | 196 | testExportedVoidFunction type 197 | testExportedBoolToStringIO type 198 | testExportedRecord 199 | testBoxingUnboxing type 200 | 201 | -- Exports 202 | 203 | createPerson : String -> String -> Person 204 | createPerson = MkPerson 205 | 206 | exportedVoidIO : CIL_IO () 207 | exportedVoidIO = putStrLn "exported!" 208 | 209 | exportedBoolToString : Bool -> String 210 | exportedBoolToString = show 211 | 212 | exportedBoolToStringIO : Bool -> CIL_IO String 213 | exportedBoolToStringIO b = do 214 | putStrLn $ "exportedBoolToStringIO " ++ show b 215 | pure $ show b 216 | 217 | exportedIncInt : Int -> Int 218 | exportedIncInt i = i + 1 219 | 220 | parameters (defaultValue: String, flag: Bool) 221 | 222 | take5 : Char -> Int -> Double -> String 223 | take5 c i d = if flag then defaultValue else show $ cast (ord c) + cast i + d 224 | 225 | exports : FFI_Export FFI_CIL "TheExports" [] -- declare exported functions on a type with given name 226 | exports = 227 | Data Person "Person" $ 228 | Fun createPerson CILDefault $ -- export function under original name 229 | Fun firstName CILDefault $ -- record field accessors are just functions and can be as easily exported 230 | Fun lastName CILDefault $ 231 | Fun exportedVoidIO (CILExport "VoidFunction") $ -- export function under custom name 232 | Fun exportedBoolToString CILDefault $ 233 | Fun exportedBoolToStringIO CILDefault $ -- export IO with return value 234 | Fun exportedIncInt CILDefault $ -- pass and get back value type 235 | Fun printMethod CILDefault $ -- export signature containing CIL type 236 | Fun take5 CILDefault 237 | End 238 | 239 | -- Local Variables: 240 | -- idris-load-packages: ("cil") 241 | -- End: 242 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Idris to Clean backend 2 | 3 | A priliminary backend for [Idris](http://www.idris-lang.org/) that compiles to [Clean](http://clean.cs.ru.nl/). 4 | 5 | ## Example 6 | 7 | ``` 8 | $ cat pythagoras.idr 9 | module Main 10 | 11 | pythagoras : Int -> List (Int, Int, Int) 12 | pythagoras max = [ 13 | (x, y, z) 14 | | z <- [1..max] 15 | , y <- [1..z] 16 | , x <- [1..y] 17 | , x * x + y *y == z * z 18 | ] 19 | 20 | main : IO () 21 | main = do 22 | [_, n] <- getArgs 23 | printLn $ pythagoras (cast n) 24 | $ idris --codegen clean pythagoras.idr -o pythagoras.icl 25 | $ clm -b -I ../Libraries/ pythagoras 26 | Compiling pythagoras 27 | Generating code for pythagoras 28 | Linking pythagoras 29 | $ ./a.out 300 30 | [(3, (4, 5)), (6, (8, 10)), (5, (12, 13)), (9, (12, 15)), (8, (15, 17)), (12, (16, 20)), (15, (20, 25)), (7, (24, 25)), (10, (24, 26)), (20, (21, 29)), (18, (24, 30)), (16, (30, 34)), (21, (28, 35)), (12, (35, 37)), (15, (36, 39)), (24, (32, 40)), (9, (40, 41)), (27, (36, 45)), (30, (40, 50)), (14, (48, 50)), (24, (45, 51)), (20, (48, 52)), (28, (45, 53)), (33, (44, 55)), (40, (42, 58)), (36, (48, 60)), (11, (60, 61)), (39, (52, 65)), (33, (56, 65)), (25, (60, 65)), (16, (63, 65)), (32, (60, 68)), (42, (56, 70)), (48, (55, 73)), (24, (70, 74)), (45, (60, 75)), (21, (72, 75)), (30, (72, 78)), (48, (64, 80)), (18, (80, 82)), (51, (68, 85)), (40, (75, 85)), (36, (77, 85)), (13, (84, 85)), (60, (63, 87)), (39, (80, 89)), (54, (72, 90)), (35, (84, 91)), (57, (76, 95)), (65, (72, 97)), (60, (80, 100)), (28, (96, 100)), (20, (99, 101)), (48, (90, 102)), (40, (96, 104)), (63, (84, 105)), (56, (90, 106)), (60, (91, 109)), (66, (88, 110)), (36, (105, 111)), (15, (112, 113)), (69, (92, 115)), (80, (84, 116)), (45, (108, 117)), (56, (105, 119)), (72, (96, 120)), (22, (120, 122)), (27, (120, 123)), (75, (100, 125)), (44, (117, 125)), (35, (120, 125)), (78, (104, 130)), (66, (112, 130)), (50, (120, 130)), (32, (126, 130)), (81, (108, 135)), (64, (120, 136)), (88, (105, 137)), (84, (112, 140)), (55, (132, 143)), (100, (105, 145)), (87, (116, 145)), (24, (143, 145)), (17, (144, 145)), (96, (110, 146)), (48, (140, 148)), (51, (140, 149)), (90, (120, 150)), (42, (144, 150)), (72, (135, 153)), (93, (124, 155)), (60, (144, 156)), (85, (132, 157)), (84, (135, 159)), (96, (128, 160)), (36, (160, 164)), (99, (132, 165)), (119, (120, 169)), (65, (156, 169)), (102, (136, 170)), (80, (150, 170)), (72, (154, 170)), (26, (168, 170)), (52, (165, 173)), (120, (126, 174)), (105, (140, 175)), (49, (168, 175)), (78, (160, 178)), (108, (144, 180)), (19, (180, 181)), (70, (168, 182)), (33, (180, 183)), (111, (148, 185)), (104, (153, 185)), (60, (175, 185)), (57, (176, 185)), (88, (165, 187)), (114, (152, 190)), (95, (168, 193)), (130, (144, 194)), (117, (156, 195)), (99, (168, 195)), (75, (180, 195)), (48, (189, 195)), (28, (195, 197)), (120, (160, 200)), (56, (192, 200)), (40, (198, 202)), (140, (147, 203)), (96, (180, 204)), (133, (156, 205)), (123, (164, 205)), (84, (187, 205)), (45, (200, 205)), (80, (192, 208)), (126, (168, 210)), (112, (180, 212)), (129, (172, 215)), (120, (182, 218)), (144, (165, 219)), (132, (176, 220)), (140, (171, 221)), (104, (195, 221)), (85, (204, 221)), (21, (220, 221)), (72, (210, 222)), (135, (180, 225)), (63, (216, 225)), (30, (224, 226)), (60, (221, 229)), (138, (184, 230)), (160, (168, 232)), (105, (208, 233)), (90, (216, 234)), (141, (188, 235)), (112, (210, 238)), (144, (192, 240)), (120, (209, 241)), (44, (240, 244)), (147, (196, 245)), (54, (240, 246)), (95, (228, 247)), (150, (200, 250)), (88, (234, 250)), (70, (240, 250)), (153, (204, 255)), (120, (225, 255)), (108, (231, 255)), (39, (252, 255)), (32, (255, 257)), (84, (245, 259)), (156, (208, 260)), (132, (224, 260)), (100, (240, 260)), (64, (252, 260)), (180, (189, 261)), (159, (212, 265)), (140, (225, 265)), (96, (247, 265)), (23, (264, 265)), (117, (240, 267)), (69, (260, 269)), (162, (216, 270)), (128, (240, 272)), (105, (252, 273)), (176, (210, 274)), (165, (220, 275)), (77, (264, 275)), (115, (252, 277)), (168, (224, 280)), (160, (231, 281)), (171, (228, 285)), (110, (264, 286)), (63, (280, 287)), (161, (240, 289)), (136, (255, 289)), (200, (210, 290)), (174, (232, 290)), (48, (286, 290)), (34, (288, 290)), (195, (216, 291)), (192, (220, 292)), (68, (285, 293)), (177, (236, 295)), (96, (280, 296)), (102, (280, 298)), (115, (276, 299)), (180, (240, 300)), (84, (288, 300))] 31 | Execution: 0.45 Garbage collection: 0.07 Total: 0.52 32 | ``` 33 | 34 | ## Purpose 35 | 36 | The purpose of this backend is to see if the [Clean programming language](https://en.wikipedia.org/wiki/Clean_(programming_language)), but especially the [ABC machine](https://en.wikipedia.org/wiki/Clean_(programming_language)#The_ABC-Machine) are a good fit for Idris. 37 | 38 | Clean is a general purpose, pure, lazy functional programming language, similar to [Haskell](https://www.haskell.org/), with lots of high level features. 39 | It's the fastest lazy language out in the wild that I know of :wink:. 40 | The ABC machine is an abstract machine to close the gap between high level functional languages and low level machine code. 41 | The four main parts of the machine are a _graph store_, containing _nodes_ (or _closures_) to be rewritten to normal form, and three stacks: 42 | 43 | - The **A**ddress or **A**rgument stack: holding references to nodes in the graph store. 44 | - The **B**asic value stack: holding basic values like `Int`s, `Char`s, `Real`s and `Bool`s. 45 | - The **C**ontrol stack: holding return addresses for control flow. 46 | 47 | The code generator for the ABC machine developed at the [Software Science group](http://www.sws.cs.ru.nl/) of the [Radboud University](http://www.ru.nl/icis) generates fast code for Intel (64-bit and 32-bit) and ARM (32-bit only) on Windows, Linux and macOS. 48 | 49 | First tests show that this backend is __3 to 4 times faster__ than Idris' current C backend (on my 2012 MacBook Air). 50 | This is _without_ any optimisations like unboxed `Bool`s, `Int`s and `Real`s that Clean and ABC use heavily. 51 | Clean's native version of the [Pythagoras benchmark](Benchmarks/pythagoras.idr) runs one order of magnitude faster, so there is a lot to win here! 52 | 53 | ## Usage 54 | 55 | ### Installing 56 | 57 | To test the code generator, clone this repository and run `cabal`. 58 | 59 | ```shell 60 | $ git clone https://github.com/timjs/idris-clean 61 | $ cd idris-clean 62 | $ cabal install 63 | ``` 64 | 65 | This should download all dependencies (including Idris itself). 66 | 67 | In the mean time (compiling Haskell takes a long time...) install Clean from ftp://ftp.cs.ru.nl/pub/Clean/builds/. 68 | Download a `clean-classic--.tgz` tarball (nothing with `itasks` in it), unpack and run `make`. 69 | Don't forget to append `clean/bin/` and `clean/lib/exe/` to your `$PATH`. 70 | 71 | ```shell 72 | $ tar -xzf clean-classic--.tgz 73 | $ cd clean 74 | $ make 75 | $ export PATH /bin/:/lib/exe/:$PATH 76 | ``` 77 | 78 | ### Running 79 | 80 | To compile an Idris file with the Clean backend run Idris with the `--codegen clean` argument and run `clm` (Clean's make utility) on the generated clean file. 81 | Do not forget to add the `Libraries/` directory to Clean's search path! 82 | 83 | ```shell 84 | $ idris --codegen clean -o 85 | $ clm -b -I /Libraries/ -o 86 | ``` 87 | 88 | Alternatively you can run the `idris-codegen-clean` utility on any already generated `.ibc` file and run `clm` afterwards. 89 | 90 | ```shell 91 | $ idris-codegen-clean -o 92 | $ clm -b -I /Libraries/ -o 93 | ``` 94 | 95 | ### Testing 96 | 97 | To run the tests or benchmarks build the files inside `Tests\` or `Benchmarks\` using [Ninja](https://ninja-build.org/). 98 | 99 | ```shell 100 | $ cd Tests 101 | $ ninja 102 | ``` 103 | 104 | ## Enjoy! 105 | 106 | This is experimental software and contains BUGS! 107 | Not all features of Idris are already implemented. 108 | Some known bugs/limitations: 109 | 110 | - `BigInt`s are implemented as native ABC `Int`s and are **not checked on overflow**. 111 | An experimental implementation with `BigInt` support can be found in the branch [`bigint`](https://github.com/timjs/idris-clean/tree/bigint) 112 | - No FFI 113 | - No unboxing 114 | 115 | 116 | -------------------------------------------------------------------------------- /Benchmarks/quasigroups.idr: -------------------------------------------------------------------------------- 1 | module Solver 2 | 3 | import Decidable.Equality 4 | import Control.Monad.State 5 | import Data.Vect 6 | import Data.Vect.Quantifiers 7 | import System 8 | 9 | -- %default total 10 | 11 | -- Solver ---------------------------------------------------------------------- 12 | 13 | Cell : Nat -> Type 14 | Cell n = Maybe (Fin n) 15 | 16 | data Board : Nat -> Type where 17 | MkBoard : {n : Nat} -> Vect n (Vect n (Cell n)) -> Board n 18 | 19 | emptyBoard : Board n 20 | emptyBoard {n=n} = MkBoard (replicate n (replicate n Nothing)) 21 | 22 | showElt : Cell n -> String 23 | showElt Nothing = "." 24 | showElt (Just x) = show (1 + (the Int (fromInteger (cast x)))) 25 | 26 | -- FIXME: Inline type decl should not be necessary here 27 | showRow : Vect n (Cell n) -> String 28 | showRow {n=n} xs = unwords (toList (the (Vect n String) (map showElt xs))) 29 | 30 | unlines : Vect n String -> String 31 | unlines Nil = "" 32 | unlines (l::Nil) = l 33 | unlines (l::ls) = pack (foldl addLine (unpack l) (map unpack ls)) 34 | where 35 | addLine : List Char -> List Char -> List Char 36 | addLine w s = w ++ ('\n' :: s) 37 | 38 | Show (Board n) where 39 | show (MkBoard rs) = unlines (map showRow rs) 40 | 41 | updateAt : Fin n -> Vect n a -> (a -> a) -> Vect n a 42 | updateAt FZ (x::xs) f = f x :: xs 43 | updateAt (FS i) (x::xs) f = x :: updateAt i xs f 44 | 45 | setCell : Board n -> (Fin n, Fin n) -> Fin n -> Board n 46 | setCell (MkBoard b) (x, y) value = MkBoard (updateAt y b (\row => updateAt x row (const (Just value)))) 47 | 48 | getCell : Board n -> (Fin n, Fin n) -> Cell n 49 | getCell (MkBoard b) (x, y) = index x (index y b) 50 | 51 | anyElim : {xs : Vect n a} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b 52 | anyElim _ f (Here p) = f p 53 | anyElim f _ (There p) = f p 54 | 55 | getRow : Fin n -> Board n -> Vect n (Cell n) 56 | getRow i (MkBoard b) = index i b 57 | 58 | getCol : Fin n -> Board n -> Vect n (Cell n) 59 | getCol i (MkBoard b) = helper i b 60 | where 61 | helper : Fin n -> Vect m (Vect n a) -> Vect m a 62 | helper _ Nil = Nil 63 | helper i (xs::xss) = index i xs :: helper i xss 64 | 65 | LegalNeighbors : Cell n -> Cell n -> Type 66 | LegalNeighbors (Just x) (Just y) = Not (x = y) 67 | LegalNeighbors _ _ = () 68 | 69 | legalNeighbors : (x : Cell n) -> (y : Cell n) -> Dec (LegalNeighbors x y) 70 | legalNeighbors (Just x) (Just y) with (decEq x y) 71 | | Yes prf = No (\pf => pf prf) 72 | | No prf = Yes prf 73 | legalNeighbors Nothing (Just _) = Yes () 74 | legalNeighbors (Just _) Nothing = Yes () 75 | legalNeighbors Nothing Nothing = Yes () 76 | 77 | rowSafe : (b : Board n) -> (r : Fin n) -> (val : Fin n) -> Dec (All (LegalNeighbors (Just val)) (getRow r b)) 78 | rowSafe b r v = all (legalNeighbors (Just v)) (getRow r b) 79 | 80 | colSafe : (b : Board n) -> (r : Fin n) -> (val : Fin n) -> Dec (All (LegalNeighbors (Just val)) (getCol r b)) 81 | colSafe b r v = all (legalNeighbors (Just v)) (getCol r b) 82 | 83 | Empty : Cell n -> Type 84 | Empty {n=n} x = (the (Cell n) Nothing) = x 85 | 86 | empty : (cell : Cell n) -> Dec (Empty cell) 87 | empty Nothing = Yes Refl 88 | empty (Just _) = No nothingNotJust 89 | 90 | -- Predicate for legal cell assignments 91 | LegalVal : Board n -> (Fin n, Fin n) -> Fin n -> Type 92 | LegalVal b (x, y) val = (Empty (getCell b (x, y)), All (LegalNeighbors (Just val)) (getCol x b), All (LegalNeighbors (Just val)) (getRow y b)) 93 | 94 | legalVal : (b : Board n) -> (coord : (Fin n, Fin n)) -> (val : Fin n) -> Dec (LegalVal b coord val) 95 | legalVal b (x, y) v = 96 | case rowSafe b y v of 97 | No prf => No (\(_, _, rf) => prf rf) 98 | Yes prf => 99 | case colSafe b x v of 100 | No prf' => No (\(_, cf, _) => prf' cf) 101 | Yes prf' => 102 | case Solver.empty (getCell b (x, y)) of 103 | No prf'' => No (\(ef, _, _) => prf'' ef) 104 | Yes prf'' => Yes (prf'', prf', prf) 105 | 106 | 107 | Filled : Cell n -> Type 108 | --Filled {n=n} x = Not (Empty x) -- TODO: Find out why this doesn't work 109 | Filled {n=n} = (\x => Not (Empty x)) 110 | --Filled {n=n} x = the (Maybe (Fin n)) Nothing = x -> Void 111 | --Filled {n=n} = \x => the (Maybe (Fin n)) Nothing = x -> Void 112 | 113 | filled : (cell : Cell n) -> Dec (Filled cell) 114 | filled Nothing = No (\f => f Refl) 115 | filled (Just _) = Yes nothingNotJust 116 | 117 | FullBoard : Board n -> Type 118 | FullBoard (MkBoard b) = All (All Filled) b 119 | 120 | fullBoard : (b : Board n) -> Dec (FullBoard b) 121 | fullBoard (MkBoard b) = all (all filled) b 122 | 123 | fins : Vect n (Fin n) 124 | fins {n=Z} = Nil 125 | fins {n=(S m)} = last :: map weaken fins 126 | 127 | data LegalBoard : Board n -> Type where 128 | Base : LegalBoard (emptyBoard {n}) 129 | Step : {b : Board n} -> {coords : (Fin n, Fin n)} -> {v : Fin n} -> LegalVal b coords v -> LegalBoard b -> LegalBoard (setCell b coords v) 130 | 131 | CompleteBoard : Board n -> Type 132 | CompleteBoard b = (LegalBoard b, FullBoard b) 133 | 134 | indexStep : {i : Fin n} -> {xs : Vect n a} -> {x : a} -> index i xs = index (FS i) (x::xs) 135 | indexStep = Refl 136 | 137 | find : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a) 138 | -> Either (All (\x => Not (P x)) xs) (y : a ** (P y, (i : Fin n ** y = index i xs))) 139 | find _ Nil = Left Nil 140 | find d (x::xs) with (d x) 141 | | Yes prf = Right (x ** (prf, (FZ ** Refl))) 142 | | No prf = 143 | case find d xs of 144 | Right (y ** (prf', (i ** prf''))) => 145 | Right (y ** (prf', (FS i ** replace {P=(\x => y = x)} (indexStep {x=x}) prf''))) 146 | Left prf' => Left (prf::prf') 147 | 148 | findEmptyInRow : (xs : Vect n (Cell n)) -> Either (All Filled xs) (i : Fin n ** Empty (index i xs)) 149 | findEmptyInRow xs = 150 | case find {P=Empty} empty xs of 151 | Right (_ ** (pempty, (i ** pidx))) => Right (i ** trans pempty pidx) 152 | Left p => Left p 153 | 154 | emptyCell : (b : Board n) -> Either (FullBoard b) (c : (Fin n, Fin n) ** Empty (getCell b c)) 155 | emptyCell (MkBoard rs) = 156 | case helper rs of 157 | Left p => Left p 158 | Right (ri ** (ci ** pf)) => Right ((ci, ri) ** pf) 159 | where 160 | helper : (rs : Vect m (Vect n (Cell n))) 161 | -> Either (All (All Filled) rs) (r : Fin m ** (c : Fin n ** Empty (index c (index r rs)))) 162 | helper Nil = Left Nil 163 | helper (r::rs) = 164 | case findEmptyInRow r of 165 | Right (ci ** pf) => Right (FZ ** (ci ** pf)) 166 | Left prf => 167 | case helper rs of 168 | Left prf' => Left (prf::prf') 169 | Right (ri ** (ci ** pf)) => Right (FS ri ** (ci ** pf)) 170 | 171 | 172 | tryValue : {b : Board (S n)} -> LegalBoard b -> (c : (Fin (S n), Fin (S n))) -> Empty (getCell b c) -> (v : Fin (S n)) 173 | -> Either (Not (LegalVal b c v)) (b' : Board (S n) ** LegalBoard b') 174 | tryValue {b=b} l c _ v = 175 | case legalVal b c v of 176 | No prf => Left prf 177 | Yes prf => Right (_ ** Step prf l) 178 | 179 | nullBoardFull : (b : Board Z) -> FullBoard b 180 | nullBoardFull (MkBoard Nil) = Nil 181 | 182 | -- TODO: Prove complete by induction on illegal values wrt. some base state, e.g. every value is illegal for 123\21_\3_2 183 | fillBoard : (b : Board n) -> LegalBoard b -> Maybe (b' : Board n ** CompleteBoard b') 184 | fillBoard {n=Z} b l = Just (b ** (l, nullBoardFull b)) 185 | fillBoard {n=(S n)} b l with (emptyCell b) 186 | | Left full = Just (b ** (l, full)) 187 | | Right (coords ** p) = recurse last 188 | where 189 | %assert_total 190 | tryAll : (v : Fin (S n)) -> (Fin (S n), Maybe (b' : Board (S n) ** LegalBoard b')) 191 | tryAll v = --trace ("Trying " ++ show (the Int (cast v))) $ 192 | case tryValue l coords p v of 193 | Right success => (v, Just success) 194 | Left _ => -- TODO: Prove unsolvable 195 | case v of 196 | FS k => tryAll (weaken k) 197 | FZ => (v, Nothing) 198 | 199 | %assert_total 200 | recurse : Fin (S n) -> Maybe (b' : Board (S n) ** CompleteBoard b') 201 | recurse start = 202 | case tryAll start of 203 | (_, Nothing) => Nothing 204 | (FZ, Just (b' ** l')) => fillBoard b' l' 205 | (FS next, Just (b' ** l')) => 206 | case fillBoard b' l' of 207 | Just solution => Just solution 208 | Nothing => recurse (weaken next) 209 | 210 | -- Parser ---------------------------------------------------------------------- 211 | 212 | ParseErr : Type 213 | ParseErr = String 214 | 215 | Parser : Nat -> Type 216 | Parser n = Either ParseErr (b : Board n ** LegalBoard b) 217 | 218 | mapM : Monad m => (a -> m b) -> Vect n a -> m (Vect n b) 219 | mapM _ Nil = pure Vect.Nil 220 | mapM f (x::xs) = do 221 | x' <- f x 222 | xs' <- mapM f xs 223 | pure (Vect.(::) x' xs') 224 | 225 | parseToken : String -> Either String (Cell n) 226 | parseToken "." = pure Nothing 227 | parseToken "0" = Left "Got cell 0, expected 1-based numbering" 228 | parseToken x = map Just (tryParseFin ((cast x) - 1)) 229 | where 230 | tryParseFin : Int -> Either String (Fin n) 231 | tryParseFin {n=Z} _ = Left ("Given cell " ++ x ++ " out of range") 232 | tryParseFin {n=S k} 0 = pure FZ 233 | tryParseFin {n=S k} x = 234 | case tryParseFin {n=k} (x-1) of 235 | Left err => Left err 236 | Right fin => pure (FS fin) 237 | 238 | length : Vect n a -> Nat 239 | length {n=n} _ = n 240 | 241 | parseCols : {b : Board n} -> Fin n -> LegalBoard b -> Vect n String -> Parser n 242 | parseCols {n=Z} _ l _ = Right (_ ** l) 243 | parseCols {n=S k} row l cs = helper last l 244 | where 245 | step : {b : Board (S k)} -> LegalBoard b -> Fin (S k) -> Parser (S k) 246 | step {b=b} l x = do 247 | let here = (x, row) -- TODO: Determine why naming this makes idris smarter 248 | tok <- parseToken {n=S k} (index x cs) 249 | case tok of 250 | Nothing => pure (_ ** l) 251 | Just t => 252 | case legalVal b here t of 253 | Yes prf => Right (_ ** Step prf l) 254 | No _ => Left ("Illegal cell " ++ index x cs) 255 | 256 | helper : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k) 257 | helper FZ l = step l FZ 258 | helper (FS k) l = do 259 | (_ ** next) <- step l (FS k) 260 | helper (weaken k) next 261 | 262 | parseRows : (b : Board n) -> LegalBoard b -> Vect n String -> Parser n 263 | parseRows {n=Z} _ l _ = Right (_ ** l) 264 | parseRows {n=S k} _ l rs = helper last l 265 | where 266 | step : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k) 267 | step i l = 268 | let cs = fromList (words (index i rs)) in 269 | case decEq (Parser.length cs) (S k) of 270 | No _ => Left "Row length not equal to column height" 271 | Yes prf => parseCols i l (replace {P=\n => Vect n String} prf cs) 272 | 273 | helper : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k) 274 | helper FZ l = step FZ l 275 | helper (FS k) l = do 276 | (_ ** next) <- step (FS k) l 277 | helper (weaken k) next 278 | 279 | parse : String -> Either String (n : Nat ** (b : Board n ** LegalBoard b)) 280 | parse str = 281 | let rows = fromList (lines str) in 282 | case parseRows {n=length rows} emptyBoard Base rows of 283 | Left msg => Left msg 284 | Right board => pure (_ ** board) 285 | 286 | -- Main ------------------------------------------------------------------------ 287 | 288 | main : IO () 289 | main = do 290 | args <- getArgs 291 | case args of 292 | [_, path] => do 293 | f <- readFile path 294 | case f of 295 | Left _err => putStrLn $ "Error reading file: " ++ path 296 | Right f' => 297 | case parse f' of 298 | Left err => putStrLn err 299 | Right (_ ** (board ** legal)) => do 300 | putStrLn "Got board:" 301 | printLn board 302 | putStrLn "Solving..." 303 | case fillBoard board legal of 304 | Nothing => putStrLn "No solution found" 305 | Just (solved ** _) => do 306 | putStrLn "Solution found:" 307 | printLn solved 308 | [self] => putStrLn ("Usage: " ++ self ++ " ") 309 | -------------------------------------------------------------------------------- /Libraries/StdPointer.icl: -------------------------------------------------------------------------------- 1 | implementation module StdPointer 2 | 3 | import StdOverloaded, StdClass, StdArray, StdInt, StdChar, StdString 4 | 5 | readInt :: !Pointer !Offset -> Int 6 | readInt pointer offset = IF_INT_64_OR_32 (readInt_64 pointer offset) (readInt_32 pointer offset) 7 | 8 | readInt_64 :: !Pointer !Offset -> Int 9 | readInt_64 pointer offset = code { 10 | pop_b 1 11 | | mov (%rbx,%rax,1),%rax 12 | instruction 72 13 | instruction 139 14 | instruction 4 15 | instruction 3 16 | } 17 | 18 | readInt_32 :: !Pointer !Offset -> Int 19 | readInt_32 pointer offset = code { 20 | pop_b 1 21 | | mov (%ebx,%eax,1),%eax 22 | instruction 139 23 | instruction 4 24 | instruction 3 25 | } 26 | 27 | readIntP :: !Pointer !Offset -> (!Int,!Pointer) 28 | readIntP pointer offset = IF_INT_64_OR_32 (readIntP_64 pointer offset) (readIntP_32 pointer offset) 29 | 30 | readIntP_64 :: !Pointer !Offset -> (!Int,!Pointer) 31 | readIntP_64 pointer offset = code { 32 | | mov (%rbx,%rax,1),%rcx 33 | instruction 72 34 | instruction 139 35 | instruction 12 36 | instruction 3 37 | | mov %rbx,%rax 38 | instruction 72 39 | instruction 139 40 | instruction 195 41 | | mov %rcx,%rbx 42 | instruction 72 43 | instruction 139 44 | instruction 217 45 | } 46 | 47 | readIntP_32 :: !Pointer !Offset -> (!Int,!Pointer) 48 | readIntP_32 pointer offset = code { 49 | | mov (%ebx,%eax,1),%ecx 50 | instruction 139 51 | instruction 12 52 | instruction 3 53 | | mov %ebx,%eax 54 | instruction 139 55 | instruction 195 56 | | mov %ecx,%ebx 57 | instruction 139 58 | instruction 217 59 | } 60 | 61 | readIntElemOffset :: !Pointer !Offset -> Int 62 | readIntElemOffset pointer offset = IF_INT_64_OR_32 (readIntElemOffset_64 pointer offset) (readIntElemOffset_32 pointer offset) 63 | 64 | readIntElemOffset_64 :: !Pointer !Offset -> Int 65 | readIntElemOffset_64 pointer offset = code { 66 | pop_b 1 67 | | mov (%rbx,%rax,8),%rax 68 | instruction 72 69 | instruction 139 70 | instruction 4 71 | instruction 195 72 | } 73 | 74 | readIntElemOffset_32 :: !Pointer !Offset -> Int 75 | readIntElemOffset_32 pointer offset = code { 76 | pop_b 1 77 | | mov (%ebx,%eax,4),%eax 78 | instruction 139 79 | instruction 4 80 | instruction 131 81 | } 82 | 83 | readIntElemOffsetP :: !Pointer !Offset -> (!Int,!Pointer) 84 | readIntElemOffsetP pointer offset = IF_INT_64_OR_32 (readIntElemOffsetP_64 pointer offset) (readIntElemOffsetP_32 pointer offset) 85 | 86 | readIntElemOffsetP_64 :: !Pointer !Offset -> (!Int,!Pointer) 87 | readIntElemOffsetP_64 pointer offset = code { 88 | | mov (%rbx,%rax,8),%rcx 89 | instruction 72 90 | instruction 139 91 | instruction 12 92 | instruction 195 93 | | mov %rbx,%rax 94 | instruction 72 95 | instruction 139 96 | instruction 195 97 | | mov %rcx,%rbx 98 | instruction 72 99 | instruction 139 100 | instruction 217 101 | } 102 | 103 | readIntElemOffsetP_32 :: !Pointer !Offset -> (!Int,!Pointer) 104 | readIntElemOffsetP_32 pointer offset = code { 105 | | mov (%ebx,%eax,4),%ecx 106 | instruction 139 107 | instruction 12 108 | instruction 131 109 | | mov %ebx,%eax 110 | instruction 139 111 | instruction 195 112 | | mov %ecx,%ebx 113 | instruction 139 114 | instruction 217 115 | } 116 | 117 | readInt32Z :: !Pointer !Offset -> Int 118 | readInt32Z pointer offset = code { 119 | pop_b 1 120 | | mov (%eax,%ebx,1),%eax 121 | instruction 139 122 | instruction 4 123 | instruction 24 124 | } 125 | 126 | readInt32S :: !Pointer !Offset -> Int 127 | readInt32S pointer offset = IF_INT_64_OR_32 (readInt32S_64 pointer offset) (readInt32S_32 pointer offset) 128 | 129 | readInt32S_64 :: !Pointer !Offset -> Int 130 | readInt32S_64 pointer offset = code { 131 | pop_b 1 132 | | movsxd rax,dword ptr [rbx+rax] 133 | instruction 72 134 | instruction 99 135 | instruction 4 136 | instruction 3 137 | } 138 | 139 | readInt32S_32 :: !Pointer !Offset -> Int 140 | readInt32S_32 pointer offset = code { 141 | pop_b 1 142 | | mov (%eax,%ebx,1),%eax 143 | instruction 139 144 | instruction 4 145 | instruction 24 146 | } 147 | 148 | readInt16Z :: !Pointer !Offset -> Int 149 | readInt16Z pointer offset = code { 150 | pop_b 1 151 | | movzwl (%eax,%ebx,1),%eax 152 | instruction 15 153 | instruction 183 154 | instruction 4 155 | instruction 24 156 | } 157 | 158 | readInt16S :: !Pointer !Offset -> Int 159 | readInt16S pointer offset = IF_INT_64_OR_32 (readInt16S_64 pointer offset) (readInt16S_32 pointer offset) 160 | 161 | readInt16S_64 :: !Pointer !Offset -> Int 162 | readInt16S_64 pointer offset = code { 163 | pop_b 1 164 | | movswl (%rax,%rbx,1),%rax 165 | instruction 72 166 | instruction 15 167 | instruction 191 168 | instruction 4 169 | instruction 24 170 | } 171 | 172 | readInt16S_32 :: !Pointer !Offset -> Int 173 | readInt16S_32 pointer offset = code { 174 | pop_b 1 175 | | movswl (%eax,%ebx,1),%eax 176 | instruction 15 177 | instruction 191 178 | instruction 4 179 | instruction 24 180 | } 181 | 182 | readInt8Z :: !Pointer !Offset -> Int 183 | readInt8Z pointer offset = code { 184 | pop_b 1 185 | | movzbl (%eax,%ebx,1),%eax 186 | instruction 15 187 | instruction 182 188 | instruction 4 189 | instruction 24 190 | } 191 | 192 | readInt8S :: !Pointer !Offset -> Int 193 | readInt8S pointer offset = IF_INT_64_OR_32 (readInt8S_64 pointer offset) (readInt8S_32 pointer offset) 194 | 195 | readInt8S_64 :: !Pointer !Offset -> Int 196 | readInt8S_64 pointer offset = code { 197 | pop_b 1 198 | | movsbl (%rax,%rbx,1),%rax 199 | instruction 72 200 | instruction 15 201 | instruction 190 202 | instruction 4 203 | instruction 24 204 | } 205 | 206 | readInt8S_32 :: !Pointer !Offset -> Int 207 | readInt8S_32 pointer offset = code { 208 | pop_b 1 209 | | movsbl (%eax,%ebx,1),%eax 210 | instruction 15 211 | instruction 190 212 | instruction 4 213 | instruction 24 214 | } 215 | 216 | readChar :: !Pointer !Offset -> Char 217 | readChar pointer offset = code { 218 | pop_b 1 219 | | movzbl (%eax,%ebx,1),%eax 220 | instruction 15 221 | instruction 182 222 | instruction 4 223 | instruction 24 224 | } 225 | 226 | readReal64 :: !Pointer !Offset -> Real 227 | readReal64 pointer offset = IF_INT_64_OR_32 (readReal64_64 pointer offset) (readReal64_32 pointer offset) 228 | 229 | readReal64_64 :: !Pointer !Offset -> Real 230 | readReal64_64 pointer offset = code { 231 | pushR 0.0 232 | updatepop_b 0 2 233 | jmp read_f8_p_64 234 | :read_f8_p_64 235 | | movsd xmm0,mmword ptr [rbx+rax] 236 | instruction 242 237 | instruction 15 238 | instruction 16 239 | instruction 4 240 | instruction 3 241 | } 242 | 243 | readReal64_32 :: !Pointer !Offset -> Real 244 | readReal64_32 pointer offset = code { 245 | pushR 0.0 246 | update_b 1 3 247 | updatepop_b 0 2 248 | jmp read_f8_p_32 249 | :read_f8_p_32 250 | | fldl (%eax,%ebx,1) 251 | instruction 221 252 | instruction 4 253 | instruction 24 254 | | fstp %st(1) 255 | instruction 221 256 | instruction 217 257 | } 258 | 259 | readReal32 :: !Pointer !Offset -> Real 260 | readReal32 pointer offset = IF_INT_64_OR_32 (readReal32_64 pointer offset) (readReal32_32 pointer offset) 261 | 262 | readReal32_64 :: !Pointer !Offset -> Real 263 | readReal32_64 pointer offset = code { 264 | pushR 0.0 265 | updatepop_b 0 2 266 | jmp read_f4_p_64 267 | :read_f4_p_64 268 | | cvtss2sd xmm0,dword ptr [rbx+rax] 269 | instruction 243 270 | instruction 15 271 | instruction 90 272 | instruction 4 273 | instruction 3 274 | } 275 | 276 | readReal32_32 :: !Pointer !Offset -> Real 277 | readReal32_32 pointer offset = code { 278 | pushR 0.0 279 | update_b 1 3 280 | updatepop_b 0 2 281 | jmp read_f4_p_32 282 | :read_f4_p_32 283 | | flds (%eax,%ebx,1) 284 | instruction 217 285 | instruction 4 286 | instruction 24 287 | | fstp %st(1) 288 | instruction 221 289 | instruction 217 290 | } 291 | 292 | writeInt :: !Pointer !Offset !Int -> Pointer 293 | writeInt pointer offset i = IF_INT_64_OR_32 (writeInt_64 pointer offset i) (writeInt_32 pointer offset i) 294 | 295 | writeInt_64 :: !Pointer !Offset !Int -> Pointer 296 | writeInt_64 pointer offset i = code { 297 | updatepop_b 0 2 298 | | mov qword ptr [rbx+r10],rax 299 | instruction 74 300 | instruction 137 301 | instruction 4 302 | instruction 19 303 | } 304 | 305 | writeInt_32 :: !Pointer !Offset !Int -> Pointer 306 | writeInt_32 pointer offset i = code { 307 | updatepop_b 0 2 308 | | mov (%esp),%ecx 309 | instruction 139 310 | instruction 12 311 | instruction 36 312 | | movl %ecx,(%eax,%ebx,1) 313 | instruction 137 314 | instruction 12 315 | instruction 24 316 | } 317 | 318 | writeIntElemOffset :: !Pointer !Offset !Int -> Pointer 319 | writeIntElemOffset pointer offset i = IF_INT_64_OR_32 (writeIntElemOffset_64 pointer offset i) (writeIntElemOffset_32 pointer offset i) 320 | 321 | writeIntElemOffset_64 :: !Pointer !Offset !Int -> Pointer 322 | writeIntElemOffset_64 pointer offset i = code { 323 | updatepop_b 0 2 324 | | mov qword ptr [r10+rbx*8],rax 325 | instruction 73 326 | instruction 137 327 | instruction 4 328 | instruction 218 329 | } 330 | 331 | writeIntElemOffset_32 :: !Pointer !Offset !Int -> Pointer 332 | writeIntElemOffset_32 pointer offset i = code { 333 | updatepop_b 0 2 334 | | mov (%esp),%ecx 335 | instruction 139 336 | instruction 12 337 | instruction 36 338 | | movl %ecx,(%ebx,%eax,4) 339 | instruction 137 340 | instruction 12 341 | instruction 131 342 | } 343 | 344 | writeInt32 :: !Pointer !Offset !Int -> Pointer 345 | writeInt32 pointer offset i = IF_INT_64_OR_32 (writeInt32_64 pointer offset i) (writeInt32_32 pointer offset i) 346 | 347 | writeInt32_64 :: !Pointer !Offset !Int -> Pointer 348 | writeInt32_64 pointer offset i = code { 349 | updatepop_b 0 2 350 | | mov dword ptr [rbx+r10],eax 351 | instruction 66 352 | instruction 137 353 | instruction 4 354 | instruction 19 355 | } 356 | 357 | writeInt32_32 :: !Pointer !Offset !Int -> Pointer 358 | writeInt32_32 pointer offset i = code { 359 | updatepop_b 0 2 360 | | mov (%esp),%ecx 361 | instruction 139 362 | instruction 12 363 | instruction 36 364 | | movl %ecx,(%eax,%ebx,1) 365 | instruction 137 366 | instruction 12 367 | instruction 24 368 | } 369 | 370 | writeInt16 :: !Pointer !Offset !Int -> Pointer 371 | writeInt16 pointer offset i = IF_INT_64_OR_32 (writeInt16_64 pointer offset i) (writeInt16_32 pointer offset i) 372 | 373 | writeInt16_64 :: !Pointer !Offset !Int -> Pointer 374 | writeInt16_64 pointer offset i = code { 375 | updatepop_b 0 2 376 | | mov word ptr [rbx+r10],ax 377 | instruction 102 378 | instruction 66 379 | instruction 137 380 | instruction 4 381 | instruction 19 382 | } 383 | 384 | writeInt16_32 :: !Pointer !Offset !Int -> Pointer 385 | writeInt16_32 pointer offset i = code { 386 | updatepop_b 0 2 387 | | mov (%esp),%ecx 388 | instruction 139 389 | instruction 12 390 | instruction 36 391 | | movw %cx,(%eax,%ebx,1) 392 | instruction 102 393 | instruction 137 394 | instruction 12 395 | instruction 24 396 | } 397 | 398 | writeInt8 :: !Pointer !Offset !Int -> Pointer 399 | writeInt8 pointer offset i = IF_INT_64_OR_32 (writeInt8_64 pointer offset i) (writeInt8_32 pointer offset i) 400 | 401 | writeInt8_64 :: !Pointer !Offset !Int -> Pointer 402 | writeInt8_64 pointer offset i = code { 403 | updatepop_b 0 2 404 | | mov byte ptr [rbx+r10],al 405 | instruction 66 406 | instruction 136 407 | instruction 4 408 | instruction 19 409 | } 410 | 411 | writeInt8_32 :: !Pointer !Offset !Int -> Pointer 412 | writeInt8_32 pointer offset i = code { 413 | updatepop_b 0 2 414 | | mov (%esp),%ecx 415 | instruction 139 416 | instruction 12 417 | instruction 36 418 | | movl %cl,(%eax,%ebx,1) 419 | instruction 136 420 | instruction 12 421 | instruction 24 422 | } 423 | 424 | writeChar :: !Pointer !Offset !Char -> Pointer 425 | writeChar pointer offset i = IF_INT_64_OR_32 (writeChar_64 pointer offset i) (writeChar_32 pointer offset i) 426 | 427 | writeChar_64 :: !Pointer !Offset !Char -> Pointer 428 | writeChar_64 pointer offset i = code { 429 | updatepop_b 0 2 430 | | mov byte ptr [rbx+r10],al 431 | instruction 66 432 | instruction 136 433 | instruction 4 434 | instruction 19 435 | } 436 | 437 | writeChar_32 :: !Pointer !Offset !Char -> Pointer 438 | writeChar_32 pointer offset i = code { 439 | updatepop_b 0 2 440 | | mov (%esp),%ecx 441 | instruction 139 442 | instruction 12 443 | instruction 36 444 | | movl %cl,(%eax,%ebx,1) 445 | instruction 136 446 | instruction 12 447 | instruction 24 448 | } 449 | 450 | writeReal64 :: !Pointer !Offset !Real -> Pointer 451 | writeReal64 pointer offset double = IF_INT_64_OR_32 (writeReal64_64 pointer offset double) (writeReal64_32 pointer offset double) 452 | 453 | writeReal64_64 :: !Pointer !Offset !Real -> Pointer 454 | writeReal64_64 pointer offset double = code { 455 | updatepop_b 0 2 456 | | movsd mmword ptr [rbx+rax],xmm0 457 | instruction 242 458 | instruction 15 459 | instruction 17 460 | instruction 4 461 | instruction 3 462 | } 463 | 464 | writeReal64_32 :: !Pointer !Offset !Real -> Pointer 465 | writeReal64_32 pointer offset double = code { 466 | updatepop_b 0 3 467 | | fstl (%eax,%ebx,1) 468 | instruction 221 469 | instruction 20 470 | instruction 24 471 | } 472 | 473 | writeReal32 :: !Pointer !Offset !Real -> Pointer 474 | writeReal32 pointer offset double = IF_INT_64_OR_32 (writeReal32_64 pointer offset double) (writeReal32_32 pointer offset double) 475 | 476 | writeReal32_64 :: !Pointer !Offset !Real -> Pointer 477 | writeReal32_64 pointer offset double = code { 478 | updatepop_b 0 2 479 | | cvtsd2ss xmm0,xmm0 480 | instruction 242 481 | instruction 15 482 | instruction 90 483 | instruction 192 484 | | movss dword ptr [rbx+rax],xmm0 485 | instruction 243 486 | instruction 15 487 | instruction 17 488 | instruction 4 489 | instruction 3 490 | } 491 | 492 | writeReal32_32 :: !Pointer !Offset !Real -> Pointer 493 | writeReal32_32 pointer offset double = code { 494 | updatepop_b 0 3 495 | | fsts (%eax,%ebx,1) 496 | instruction 217 497 | instruction 20 498 | instruction 24 499 | } 500 | 501 | derefInt :: !Pointer -> Int 502 | derefInt ptr = code { 503 | load_i 0 504 | } 505 | 506 | derefString :: !Pointer -> String 507 | derefString ptr = copy ptr 0 (createArray len '\0') 508 | where 509 | len = skip_to_zero ptr - ptr 510 | 511 | skip_to_zero ptr 512 | | load_char ptr <> '\0' = skip_to_zero (ptr+1) 513 | = ptr 514 | 515 | copy :: !Pointer !Offset *{#Char} -> *{#Char} 516 | copy ptr off arr 517 | # char = load_char (ptr+off) 518 | | char <> '\0' = copy ptr (off + 1) {arr & [off] = char} 519 | = arr 520 | 521 | derefCharArray :: !Pointer !Int -> {#Char} 522 | derefCharArray ptr len = copy 0 (createArray len '\0') 523 | where 524 | copy :: !Offset *{#Char} -> *{#Char} 525 | copy off arr 526 | # char = load_char (ptr+off) 527 | | off < len = copy (inc off) {arr & [off] = char} 528 | = arr 529 | 530 | load_char :: !Pointer -> Char 531 | load_char ptr = code inline { 532 | load_ui8 0 533 | } 534 | 535 | writeCharArray :: !Pointer !{#Char} -> Pointer 536 | writeCharArray ptr array = copy ptr 0 537 | where 538 | len = size array 539 | 540 | copy :: !Pointer !Offset -> Pointer 541 | copy ptr off 542 | # char = array.[off] 543 | | off < len = copy (writeChar ptr off char) (inc off) 544 | = ptr 545 | 546 | packInt :: !Int -> {#Int} 547 | packInt i = {i} 548 | 549 | packString :: !String -> {#Char} 550 | packString s = s +++ "\0" 551 | 552 | unpackString :: !{#Char} -> String 553 | unpackString s = unpack 0 554 | where 555 | unpack :: Int -> String 556 | unpack off | s.[off] == '\0' = s % (0, off - 1) 557 | | otherwise = unpack (off + 1) 558 | 559 | unpackInt16Z :: !{#Char} !Offset -> Int 560 | unpackInt16Z s off 561 | = (toInt s.[off]) 562 | bitor (toInt s.[off + 1] << 8) 563 | 564 | unpackInt16S :: !{#Char} !Offset -> Int 565 | unpackInt16S s off = IF_INT_64_OR_32 (((unpackInt16Z s off) << 48) >> 48) (((unpackInt16Z s off) << 16) >> 16) 566 | 567 | unpackInt32Z :: !{#Char} !Offset -> Int 568 | unpackInt32Z s off 569 | = (toInt s.[off]) 570 | bitor (toInt s.[off + 1] << 8) 571 | bitor (toInt s.[off + 2] << 16) 572 | bitor (toInt s.[off + 3] << 24) 573 | 574 | unpackInt32S :: !{#Char} !Offset -> Int 575 | unpackInt32S s off = IF_INT_64_OR_32 (((unpackInt32Z s off) << 32) >> 32) (unpackInt32Z s off) 576 | 577 | unpackInt64 :: !{#Char} !Offset -> Int 578 | unpackInt64 s off 579 | = (toInt s.[off]) 580 | bitor (toInt s.[off + 1] << 8) 581 | bitor (toInt s.[off + 2] << 16) 582 | bitor (toInt s.[off + 3] << 24) 583 | bitor (toInt s.[off + 4] << 32) 584 | bitor (toInt s.[off + 5] << 40) 585 | bitor (toInt s.[off + 6] << 48) 586 | bitor (toInt s.[off + 7] << 56) 587 | 588 | unpackBool :: !{#Char} !Offset -> Bool 589 | unpackBool s off = unpackInt32Z s off <> 0 590 | 591 | forceEval :: !a !*env -> *env 592 | forceEval _ world = world 593 | 594 | forceEvalPointer :: !Pointer !*env -> *env 595 | forceEvalPointer _ world = world 596 | 597 | global_argc :: Pointer 598 | global_argc = code { 599 | pushLc global_argc 600 | } 601 | 602 | global_argv :: Pointer 603 | global_argv = code { 604 | pushLc global_argv 605 | } 606 | -------------------------------------------------------------------------------- /Sources/IRTS/CodegenClean.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module IRTS.CodegenClean 3 | ( codegenClean 4 | ) where 5 | 6 | import Prelude hiding ((<$>)) 7 | 8 | import IRTS.CodegenCommon 9 | import IRTS.Lang 10 | import IRTS.Defunctionalise 11 | import Idris.Core.TT 12 | 13 | import Numeric (showHex) 14 | import Data.Char 15 | import Data.List 16 | import Data.Text.Lazy (Text, pack, unpack) 17 | import System.IO 18 | import System.FilePath 19 | 20 | import Text.PrettyPrint.Leijen.Text hiding (string) 21 | import qualified Text.PrettyPrint.Leijen.Text as Pretty 22 | 23 | -- Helpers --------------------------------------------------------------------- 24 | 25 | string :: String -> Doc 26 | string = text . pack 27 | 28 | blank :: Doc 29 | blank = space 30 | 31 | deline, dequote :: String -> String 32 | deline = map (\c -> if c == '\n' then ' ' else c) 33 | dequote = map (\c -> if c == '"' then '\'' else c) 34 | fixExponent = map (\c -> if c == 'e' then 'E' else c) 35 | 36 | appPrefix, appInfix :: Doc -> [Doc] -> Doc 37 | appPrefix fun args = parens $ 38 | fun <+> hsep args 39 | appInfix op [left, right] = parens $ 40 | left <+> op <+> right 41 | 42 | -- Main and Prelude ------------------------------------------------------------ 43 | 44 | codegenClean :: CodeGenerator 45 | codegenClean info = do 46 | let (funcs, ctors) = partition isFun (defunDecls info) 47 | let output = vsep $ intersperse blank 48 | [ cgModule (takeBaseName $ outputFile info) 49 | , cgImports 50 | , cgPredefined 51 | , cgConstructors ctors 52 | , cgFunctions funcs 53 | , cgStart 54 | ] 55 | withFile (outputFile info) WriteMode (`hPutDoc` output) 56 | where 57 | isFun (_, DFun{}) = True 58 | isFun (_, DConstructor{}) = False 59 | 60 | cgModule :: String -> Doc 61 | cgModule name = "module" <+> string name 62 | 63 | cgImports, cgPredefined, cgStart :: Doc 64 | cgImports = vsep $ map ("import" <+>) 65 | [ "StdEnv" 66 | , "StdPointer" 67 | ] 68 | cgPredefined = vsep 69 | [ ":: Value = Nothing" 70 | , " | Boxed_Bool !Bool" 71 | , " | Boxed_Char !Char" 72 | , " | Boxed_Int !Int" 73 | , " | Boxed_Real !Real" 74 | , " | Boxed_String !String" 75 | , " | .." 76 | , blank 77 | , "unbox_Bool (Boxed_Bool x) :== x" 78 | , "unbox_Char (Boxed_Char x) :== x" 79 | , "unbox_Int (Boxed_Int x) :== x" 80 | , "unbox_Real (Boxed_Real x) :== x" 81 | , "unbox_String (Boxed_String x) :== x" 82 | , blank 83 | , "clean_String_cons (Boxed_Char chr) (Boxed_String str) :== Boxed_String (toString chr +++ str)" 84 | , "clean_String_reverse (Boxed_String str) :== Boxed_String { str.[i] \\\\ i <- reverse [0..size str - 1] }" 85 | , "clean_String_head (Boxed_String str) :== Boxed_Char (select str 0)" 86 | , "clean_String_tail (Boxed_String str) :== Boxed_String (str % (1, size str - 1))" 87 | , "clean_String_index (Boxed_String str) (Boxed_Int i) :== Boxed_Char (select str i)" 88 | , "clean_String_len (Boxed_String str) :== Boxed_Int (size str)" 89 | , "clean_String_substring (Boxed_Int ofs) (Boxed_Int len) (Boxed_String str) :== Boxed_String (str % (ofs, ofs + len - 1))" 90 | , blank 91 | , "clean_System_write_String world (Boxed_String str) | clean_Prim_toStdout str :== Nothing" 92 | , "clean_System_read_String world" 93 | , " # (str, ok) = clean_Prim_fromStdin" 94 | , " | ok :== Boxed_String str" 95 | , "clean_System_numArgs world :== Boxed_Int (fst clean_Prim_args)" 96 | --cgForeign (FApp C_IntT [FUnknown,FCon C_IntNative]) (FStr "idris_numArgs") [] = 97 | , "clean_System_getArgs (Boxed_Int idx) :== Boxed_String ((snd clean_Prim_args) !! idx)" 98 | --cgForeign (FCon C_Str) (FStr "idris_getArg") [(FApp C_IntT [FUnknown,FCon C_IntNative], exp)] = 99 | , blank 100 | , "clean_Prim_toStdout :: !String -> Bool" 101 | , "clean_Prim_toStdout str = code inline {" 102 | , " .d 1 0" 103 | , " jsr stdioF" 104 | , " .o 1 2 f" 105 | , " .d 1 2 f" 106 | , " jsr writeFS" 107 | , " .o 0 2 f" 108 | , " .d 0 2 f" 109 | , " jsr closeF" 110 | , " .o 0 1 b" 111 | , "}" 112 | , "clean_Prim_fromStdin :: (!String,!Bool)" 113 | , "clean_Prim_fromStdin = code inline {" 114 | , " .d 0 0" 115 | , " jsr stdioF" 116 | , " .o 0 2 f" 117 | , " .d 0 2 f" 118 | , " jsr readLineF" 119 | , " .o 1 2 f" 120 | , " .d 0 2 f" 121 | , " jsr closeF" 122 | , " .o 0 1 b" 123 | , "}" 124 | , "clean_Prim_args :: (!Int, [String])" 125 | , "clean_Prim_args" 126 | , " # argc = readInt32Z global_argc 0" 127 | , " # argv = derefInt global_argv" 128 | , " = (argc, [derefString (readInt argv (i << (IF_INT_64_OR_32 3 2)) ) \\\\ i <- [0..argc - 1]])" 129 | ] 130 | cgStart = vsep 131 | [ "Start =" <+> cgFunName (MN 0 "runMain") ] 132 | 133 | -- Declarations and Expressions ------------------------------------------------ 134 | 135 | cgConstructors :: [(Name, DDecl)] -> Doc 136 | cgConstructors decls = 137 | ":: Value" <+> align (vsep $ map (cgCon . snd) decls) 138 | 139 | cgCon :: DDecl -> Doc 140 | cgCon (DConstructor name tag arity) = 141 | --FIXME strictness 142 | "///" <+> string (show name) <+> parens (int tag) <$> 143 | char '|' <+> cgConName name <+> hsep (replicate arity "!Value") 144 | 145 | cgFunctions :: [(Name, DDecl)] -> Doc 146 | cgFunctions = vsep . map (cgFun . snd) 147 | 148 | cgFun :: DDecl -> Doc 149 | cgFun (DFun name args def) = 150 | let arity = length args in 151 | blank <$> 152 | "///" <+> (string . show) name <$> 153 | "///" <+> (string . deline . show) def <$> 154 | cgFunName name <+> "::" <+> (if arity > 0 155 | then hsep (replicate arity "!Value") <+> "->" 156 | else empty) <+> "Value" <$> 157 | cgFunName name <+> hsep (map cgVarName args) <$> 158 | char '=' <+> align (cgExp def) 159 | 160 | cgExp :: DExp -> Doc 161 | cgExp (DV var) = 162 | cgVar var 163 | cgExp (DApp _istail name args) = 164 | cgFn (cgFunName name) args 165 | cgExp (DLet name def rest) = 166 | cgLet name def rest 167 | cgExp (DUpdate var def) = 168 | --cgLet var def Nothing 169 | cgExp def 170 | cgExp (DProj def idx) = 171 | cgUnsupported "PROJECT" (def, idx) 172 | --cgExp def <+> brackets (int idx) 173 | -- Constructors: False, True 174 | -- cgExp (DC _ 0 name []) | name == falseName = 175 | -- cgBox BBool "False" 176 | -- cgExp (DC _ 1 name []) | name == trueName = 177 | -- cgBox BBool "True" 178 | -- Constructors: rest 179 | cgExp (DC _reloc _tag name args) = 180 | --FIXME optimize to Int for argless ctors 181 | cgFn (cgConName name) args 182 | -- Case: if-then-else 183 | -- cgExp (DCase _ test [DConCase 0 false [] elseAlt, DConCase 1 true [] thenAlt]) | false == falseName && true == trueName = 184 | -- cgIfThenElse test thenAlt elseAlt 185 | -- cgExp (DCase _ test [DConCase 1 true [] thenAlt, DConCase 0 false [] elseAlt]) | false == falseName && true == trueName = 186 | -- cgIfThenElse test thenAlt elseAlt 187 | -- cgExp (DCase _ test [DConCase 0 false [] elseAlt, DDefaultCase thenAlt ]) | false == falseName = 188 | -- cgIfThenElse test thenAlt elseAlt 189 | -- cgExp (DCase _ test [DConCase 1 true [] thenAlt, DDefaultCase elseAlt ]) | true == trueName = 190 | -- cgIfThenElse test thenAlt elseAlt 191 | cgExp (DCase _ test [DConstCase (I 0) elseAlt, DDefaultCase thenAlt]) = 192 | cgIfThenElse test thenAlt elseAlt 193 | --cgExp (DCase _ test [t@SConstCase{}, e@SDefaultCase{}, SDefaultCase{}]) = emit (SCase Shared v [t, e]) 194 | -- Case: rest 195 | cgExp (DCase _casetype exp alts) = 196 | cgCase exp alts 197 | cgExp (DChkCase exp alts) = 198 | cgCase exp alts 199 | cgExp (DConst const) = 200 | cgConst const 201 | cgExp (DOp prim exps) = 202 | cgPrim prim exps 203 | cgExp (DForeign fun ret args) = 204 | cgForeign fun ret args 205 | cgExp DNothing = 206 | "Nothing" --cgUnsupported "NOTHING" () 207 | cgExp (DError msg) = 208 | appPrefix "abort" [dquotes $ string msg] 209 | 210 | cgLet :: Name -> DExp -> DExp -> Doc 211 | cgLet name def rest = 212 | --FIXME should be strict always? 213 | "let" <+> cgVarName name <+> char '=' <+> cgExp def <$> 214 | "in " <+> align ( 215 | cgExp rest 216 | ) 217 | 218 | cgIfThenElse :: DExp -> DExp -> DExp -> Doc 219 | cgIfThenElse test thenAlt elseAlt = 220 | "if" <+> align ( 221 | cgUnbox BBool (cgExp test) <$> 222 | parens (cgExp thenAlt) <$> 223 | parens (cgExp elseAlt) 224 | ) 225 | 226 | cgCase :: DExp -> [DAlt] -> Doc 227 | cgCase exp alts = 228 | -- parens for `case` in `case` 229 | parens $ "case" <+> align ( 230 | cgExp exp <+> "of" <$> 231 | vsep (map cgAlt alts) 232 | ) 233 | 234 | cgAlt :: DAlt -> Doc 235 | cgAlt (DConCase _tag name args exp) = 236 | cgConName name <+> hsep (map cgVarName args) <+> "->" <+> align (cgExp exp) 237 | cgAlt (DConstCase const exp) = 238 | cgConst const <+> "->" <+> align (cgExp exp) 239 | cgAlt (DDefaultCase exp) = 240 | char '_' <+> "->" <+> align (cgExp exp) 241 | 242 | -- Foreign Calls --------------------------------------------------------------- 243 | 244 | cgForeign :: FDesc -> FDesc -> [(FDesc, DExp)]-> Doc 245 | cgForeign _ (FStr "idris_numArgs") [] = 246 | cgFn "clean_System_numArgs" [DNothing] 247 | cgForeign _ (FStr "idris_getArg") [(_, exp)] = 248 | cgFn "clean_System_getArgs" [exp] 249 | cgForeign fun ret args = 250 | cgUnsupported "FOREIGN CALL" (fun, ret, args) 251 | 252 | -- Constants and Primitives ---------------------------------------------------- 253 | 254 | cgConst :: Const -> Doc 255 | cgConst (I i) = cgBox BInt $ int i 256 | cgConst (BI i) = cgBox BInt $ if validInt i then integer i else cgUnsupported "BIG INTEGER VALUE" i 257 | -- Translate all bit types to `BInt`, Clean doesn't have different integer sizes. 258 | cgConst (B8 i) = cgBox BInt . string . show $ i 259 | cgConst (B16 i) = cgBox BInt . string . show $ i 260 | cgConst (B32 i) = cgBox BInt . string . show $ i 261 | cgConst (B64 i) = cgBox BInt . string . show $ i 262 | cgConst (Fl d) = cgBox BReal . string . fixExponent . show $ d 263 | cgConst (Ch c) = cgBox BChar . squotes . string . cgEscape False $ c 264 | cgConst (Str s) = cgBox BString . dquotes . string . concatMap (cgEscape True) $ s 265 | cgConst c = cgUnsupported "CONSTANT" c 266 | 267 | cgEscape :: Bool -> Char -> String 268 | cgEscape True '"' = "\\\"" 269 | cgEscape False '\'' = "\\'" 270 | cgEscape _ '\\' = "\\\\" 271 | cgEscape isString c 272 | | c >= ' ' && c < '\x7F' = [c] 273 | | c <= '\xFF' = "\\x" ++ showHex (ord c) "" 274 | | otherwise = error $ "idris-codegen-clean: char " ++ show c ++ " is bigger than 255" 275 | 276 | cgPrim :: PrimFn -> [DExp] -> Doc 277 | cgPrim (LPlus ty) = cgPrimOp (cgATy ty) "+" 278 | cgPrim (LMinus ty) = cgPrimOp (cgATy ty) "-" 279 | cgPrim (LTimes ty) = cgPrimOp (cgATy ty) "*" 280 | cgPrim (LSDiv ty) = cgPrimOp (cgATy ty) "/" 281 | cgPrim (LUDiv ty) = cgPrimOp (cgITy ty) "/" 282 | cgPrim (LSRem ty) = cgPrimOp (cgATy ty) "rem" 283 | cgPrim (LURem ty) = cgPrimOp (cgITy ty) "rem" 284 | 285 | cgPrim (LAnd ty) = cgPrimOp (cgITy ty) "bitand" 286 | cgPrim (LOr ty) = cgPrimOp (cgITy ty) "bitor" 287 | cgPrim (LXOr ty) = cgPrimOp (cgITy ty) "bitxor" 288 | cgPrim (LSHL ty) = cgPrimOp (cgITy ty) "<<" 289 | cgPrim (LASHR ty) = cgPrimOp (cgITy ty) ">>" 290 | cgPrim (LLSHR ty) = cgPrimOp (cgITy ty) ">>" --FIXME 291 | --cgPrim (LCompl _) = \[x] -> text "~" <> x 292 | 293 | cgPrim (LEq ty) = cgReboxOp (cgATy ty) BBool "==" 294 | cgPrim (LLt ty) = cgReboxOp (cgITy ty) BBool "<" 295 | cgPrim (LSLt ty) = cgReboxOp (cgATy ty) BBool "<" 296 | cgPrim (LLe ty) = cgReboxOp (cgITy ty) BBool "<=" 297 | cgPrim (LSLe ty) = cgReboxOp (cgATy ty) BBool "<=" 298 | cgPrim (LGt ty) = cgReboxOp (cgITy ty) BBool ">" 299 | cgPrim (LSGt ty) = cgReboxOp (cgATy ty) BBool ">" 300 | cgPrim (LGe ty) = cgReboxOp (cgITy ty) BBool ">=" 301 | cgPrim (LSGe ty) = cgReboxOp (cgATy ty) BBool ">=" 302 | 303 | --XXX Only Char to Int and Int to Char? Rest is 64bit on 64bit machines... 304 | cgPrim (LSExt _ _) = cgFn "id" 305 | cgPrim (LZExt _ _) = cgFn "id" 306 | cgPrim (LBitCast _ _) = cgFn "id" 307 | cgPrim (LTrunc _ _) = cgFn "id" 308 | 309 | cgPrim LStrConcat = cgPrimOp BString "+++" 310 | cgPrim LStrLt = cgReboxOp BString BBool "<" 311 | cgPrim LStrEq = cgReboxOp BString BBool "==" 312 | 313 | cgPrim LStrRev = cgFn "clean_String_reverse" 314 | cgPrim LStrCons = cgFn "clean_String_cons" 315 | cgPrim LStrHead = cgFn "clean_String_head" 316 | cgPrim LStrTail = cgFn "clean_String_tail" 317 | cgPrim LStrIndex = cgFn "clean_String_index" 318 | cgPrim LStrLen = cgFn "clean_String_len" 319 | cgPrim LStrSubstr = cgFn "clean_String_substring" 320 | 321 | cgPrim LWriteStr = cgFn "clean_System_write_String" 322 | cgPrim LReadStr = cgFn "clean_System_read_String" 323 | 324 | --cgPrim (LExternal n) = cgExtern $ show n 325 | 326 | cgPrim (LChInt ty) = cgReboxFn BChar (cgITy ty) "toInt" 327 | cgPrim (LIntCh ty) = cgReboxFn (cgITy ty) BChar "toChar" 328 | cgPrim (LIntStr ty) = cgReboxFn (cgITy ty) BString "toString" 329 | cgPrim (LStrInt ty) = cgReboxFn BString (cgITy ty) "toInt" 330 | cgPrim (LIntFloat ty) = cgReboxFn (cgITy ty) BReal "toReal" 331 | cgPrim (LFloatInt ty) = cgReboxFn BReal (cgITy ty) "toInt" 332 | cgPrim LFloatStr = cgReboxFn BReal BString "toString" 333 | cgPrim LStrFloat = cgReboxFn BString BReal "toReal" 334 | 335 | cgPrim LFExp = cgPrimFn BReal "exp" 336 | cgPrim LFLog = cgPrimFn BReal "log" 337 | cgPrim LFSin = cgPrimFn BReal "sin" 338 | cgPrim LFCos = cgPrimFn BReal "cos" 339 | cgPrim LFTan = cgPrimFn BReal "tan" 340 | cgPrim LFASin = cgPrimFn BReal "asin" 341 | cgPrim LFACos = cgPrimFn BReal "acos" 342 | cgPrim LFATan = cgPrimFn BReal "atan" 343 | cgPrim LFSqrt = cgPrimFn BReal "sqrt" 344 | cgPrim LFFloor = cgReboxFn BReal BInt "entier" 345 | --cgPrim LFCeil = cgReboxFn BReal BInt "ceil" 346 | cgPrim LFNegate = cgPrimFn BReal "~" -- \[x] -> text "~" <> x 347 | 348 | cgPrim f = \args -> cgUnsupported "PRIMITIVE" (f, args) 349 | 350 | cgPrimFn, cgPrimOp :: BoxedTy -> Doc -> [DExp] -> Doc 351 | cgPrimFn ty = cgReboxFn ty ty 352 | cgPrimOp ty = cgReboxOp ty ty 353 | cgReboxFn, cgReboxOp :: BoxedTy -> BoxedTy -> Doc -> [DExp] -> Doc 354 | cgReboxFn = cgRebox appPrefix 355 | cgReboxOp = cgRebox appInfix 356 | 357 | data BoxedTy 358 | = BBool 359 | | BChar 360 | | BInt 361 | | BReal 362 | | BString 363 | 364 | instance Pretty BoxedTy where 365 | pretty BBool = "Bool" 366 | pretty BChar = "Char" 367 | pretty BInt = "Int" 368 | pretty BReal = "Real" 369 | pretty BString = "String" 370 | 371 | -- Translate all `IntTy`s to `BInt` except for characters. 372 | -- FIXME No good for `Integer`, but it it used as an intermediate result in 373 | -- multiple basic Idris functions like `String` lengths etc. 374 | cgITy :: IntTy -> BoxedTy 375 | cgITy ITNative = BInt 376 | cgITy ITBig = BInt 377 | cgITy ITChar = BChar 378 | cgITy (ITFixed IT8) = BInt 379 | cgITy (ITFixed IT16) = BInt 380 | cgITy (ITFixed IT32) = BInt 381 | cgITy (ITFixed IT64) = BInt 382 | 383 | cgATy :: ArithTy -> BoxedTy 384 | cgATy ATFloat = BReal 385 | cgATy (ATInt ity) = cgITy ity 386 | 387 | -- Names & Applications -------------------------------------------------------- 388 | 389 | cgBox, cgUnbox :: BoxedTy -> Doc -> Doc 390 | cgBox ty exp = appPrefix ("Boxed_" <> pretty ty) [exp] 391 | cgUnbox ty exp = appPrefix ("unbox_" <> pretty ty) [exp] 392 | 393 | cgRebox :: (Doc -> [Doc] -> Doc) -> BoxedTy -> BoxedTy -> Doc -> [DExp] -> Doc 394 | cgRebox app from to fun = cgBox to . app fun . map (cgUnbox from . cgExp) 395 | 396 | cgFn :: Doc -> [DExp] -> Doc 397 | cgFn fun args = appPrefix fun (map cgExp args) 398 | 399 | cgVar :: LVar -> Doc 400 | cgVar (Loc idx) = cgLoc idx --FIXME not in ir? 401 | cgVar (Glob name) = cgVarName name 402 | 403 | cgLoc :: Int -> Doc 404 | cgLoc idx = "x" <> int idx 405 | 406 | cgFunName, cgConName, cgVarName :: Name -> Doc 407 | cgFunName name = string . fixMangle $ "idris_" ++ mangle name 408 | cgConName name = string . fixMangle $ "Idris_" ++ mangle name 409 | cgVarName name = string . fixMangle $ mangle name 410 | 411 | -- Fixes mkFnCon and mkUnderCon from IRTS.Defunctionalise 412 | fixMangle :: String -> String 413 | fixMangle name@(c:cs) 414 | -- Parameters of underapplied functions 415 | | "P_" `isPrefixOf` name = toLower c : cs 416 | -- Calls to partial constructors (?) 417 | | "idris_P_" `isPrefixOf` name = toUpper c : cs 418 | -- Calls to underapplied functions 419 | | "idris_U_" `isPrefixOf` name = toUpper c : cs 420 | | otherwise = name 421 | 422 | mangle :: Name -> String 423 | mangle name = concatMap mangleChar (showCG name) 424 | where 425 | mangleChar c 426 | | isIdent c = [c] 427 | | isSep c = "_" 428 | | isBrace c = "" 429 | | otherwise = "_" ++ show (fromEnum c) ++ "_" 430 | isIdent c = isAlpha c || isDigit c || c == '_' 431 | isSep c = c == '.' 432 | isBrace c = c == '{' || c == '}' 433 | 434 | validInt :: Integer -> Bool 435 | validInt i = i > minInt && i < maxInt 436 | where 437 | minInt = -(2^63) 438 | maxInt = 2^63 - 1 439 | 440 | falseName, trueName :: Name 441 | falseName = NS (UN "False") ["Bool", "Prelude"] 442 | trueName = NS (UN "True") ["Bool", "Prelude"] 443 | 444 | -- Unsupported ----------------------------------------------------------------- 445 | 446 | cgUnsupported :: Show a => Text -> a -> Doc 447 | cgUnsupported msg val = 448 | appPrefix "abort" [dquotes $ text msg <+> (string . dequote . show) val <+> "IS UNSUPPORTED"] 449 | --------------------------------------------------------------------------------