├── .gitattributes ├── .gitignore ├── .travis.yml ├── LICENSE.txt ├── Makefile ├── README.md ├── build-instructions.md ├── contrib └── dgronau │ ├── Alternative.fr │ ├── Floating.fr │ ├── HashMap.fr │ ├── HashSet.fr │ ├── Map.fr │ ├── Math.fr │ ├── Monadic.fr │ ├── Or.fr │ ├── RaList.fr │ ├── Seq.fr │ ├── Set.fr │ ├── arrow │ ├── Arrow.fr │ └── Category.fr │ ├── comonad │ ├── Comonad.fr │ └── Extend.fr │ └── trans │ ├── EitherT.fr │ ├── MaybeT.fr │ ├── MonadIO.fr │ ├── MonadTrans.fr │ ├── StateT.fr │ └── TransTest.fr ├── doc ├── Implementation.tex ├── Language.tex ├── Makefile ├── chapterdeclarations.tex ├── chapterderived.tex ├── chapterexpr.tex ├── chapterio.tex ├── chapterlex.tex ├── chaptermodules.tex ├── chapternative.tex ├── chaptertypes.tex └── utfcode.eps ├── examples ├── Brainfuck.fr ├── CombinatorEvolution.fr ├── CommandLineClock.fr ├── Concurrent.fr ├── DamenF.fr ├── DigitSum.fr ├── Distance.fr ├── Diverge.fr ├── Euler.fr ├── Euler12.fr ├── Euler7.fr ├── Euler87.fr ├── Euler92.fr ├── Euler93.fr ├── Euler94.fr ├── Euler95.fr ├── EulerLib.fr ├── Evolution.fr ├── FBodies.fr ├── ForH.fr ├── Fpidigits.fr ├── FunctionInstances.fr ├── GoldenRatio.fr ├── Grep.fr ├── HigherOrder.fr ├── JHashMap.java ├── JSONExample.fr ├── LBodies.fr ├── MapTest.fr ├── MoreTailCall.fr ├── NumericLiterals.fr ├── PointFree.fr ├── Postfix.fr ├── Records.fr ├── RefExample.fr ├── ReverseStdin.fr ├── STM.fr ├── SimpleIO.fr ├── Sort.fr ├── Sudoku.fr ├── SwingExamples.fr ├── TailCalls.fr ├── UnicodeChars.fr ├── Welcome.fr ├── YearNumbers.fr ├── euler-sudoku.txt └── top95.txt ├── frege ├── Prelude.fr ├── StandardLibrary.fr ├── StandardTools.fr ├── Starter.fr ├── compiler │ ├── Classes.fr │ ├── Classtools.fr │ ├── GenMeta.fr │ ├── Javatypes.fr │ ├── Kinds.fr │ ├── Main.fr │ ├── Typecheck.fr │ ├── Utilities.fr │ ├── classes │ │ ├── Nice.fr │ │ └── QNameMatcher.fr │ ├── common │ │ ├── Annotate.fr │ │ ├── AnnotateG.fr │ │ ├── Binders.fr │ │ ├── CompilerOptions.fr │ │ ├── Desugar.fr │ │ ├── Errors.fr │ │ ├── ImpExp.fr │ │ ├── JavaName.fr │ │ ├── Mangle.fr │ │ ├── PatternCompiler.fr │ │ ├── Resolve.fr │ │ ├── Roman.fr │ │ ├── SymbolTable.fr │ │ ├── Trans.fr │ │ ├── Tuples.fr │ │ ├── Types.fr │ │ └── UnAlias.fr │ ├── enums │ │ ├── CaseKind.fr │ │ ├── Flags.fr │ │ ├── Literals.fr │ │ ├── RFlag.fr │ │ ├── SymState.fr │ │ ├── TokenID.fr │ │ └── Visibility.fr │ ├── gen │ │ └── java │ │ │ ├── Bindings.fr │ │ │ ├── Common.fr │ │ │ ├── Constants.fr │ │ │ ├── DataCode.fr │ │ │ ├── InstanceCode.fr │ │ │ ├── Instantiation.fr │ │ │ ├── Match.fr │ │ │ ├── MethodCall.fr │ │ │ ├── PrettyJava.fr │ │ │ └── VarCode.fr │ ├── grammar │ │ ├── Frege.fr │ │ ├── Frege.y │ │ ├── Grammar.ebnf │ │ ├── Lexer.fr │ │ └── Lexical.ebnf │ ├── instances │ │ ├── NiceExprS.fr │ │ ├── Nicer.fr │ │ └── PositionedSName.fr │ ├── passes │ │ ├── Easy.fr │ │ ├── Enter.fr │ │ ├── Fields.fr │ │ ├── Final.fr │ │ ├── Fix.fr │ │ ├── GenCode.fr │ │ ├── GlobalLam.fr │ │ ├── Imp.fr │ │ ├── Instances.fr │ │ ├── LetUnroll.fr │ │ ├── Strict.fr │ │ ├── Transdef.fr │ │ └── TypeAlias.fr │ ├── tc │ │ ├── Methods.fr │ │ ├── Patterns.fr │ │ └── Util.fr │ └── types │ │ ├── AbstractJava.fr │ │ ├── ConstructorField.fr │ │ ├── Expression.fr │ │ ├── External.fr │ │ ├── Global.fr │ │ ├── ImportDetails.fr │ │ ├── JNames.fr │ │ ├── NSNames.fr │ │ ├── Packs.fr │ │ ├── Patterns.fr │ │ ├── Positions.fr │ │ ├── QNames.fr │ │ ├── SNames.fr │ │ ├── SourceDefinitions.fr │ │ ├── Strictness.fr │ │ ├── Symbols.fr │ │ ├── Targets.fr │ │ ├── Tokens.fr │ │ └── Types.fr ├── control │ ├── Arrow.fr │ ├── Category.fr │ ├── CombineIn.fr │ ├── Concurrent.fr │ ├── DeepSeq.fr │ ├── First.fr │ ├── Second.fr │ ├── Semigroupoid.fr │ ├── Tensor.fr │ ├── arrow │ │ └── Kleisli.fr │ ├── concurrent │ │ └── STM.fr │ └── monad │ │ ├── Reader.fr │ │ ├── State.fr │ │ └── trans │ │ ├── EitherT.fr │ │ ├── MaybeT.fr │ │ ├── MonadIO.fr │ │ └── MonadTrans.fr ├── data │ ├── Array.fr │ ├── Bits.fr │ ├── Char.fr │ ├── Compose.fr │ ├── Coproduct.fr │ ├── Dec64.fr │ ├── Either.fr │ ├── Foldable.fr │ ├── Graph.fr │ ├── HashMap.fr │ ├── Iterators.fr │ ├── Ix.fr │ ├── JSON.fr │ ├── List.fr │ ├── Maybe.fr │ ├── MicroParsec.fr │ ├── Monoid.fr │ ├── NanoParsec.fr │ ├── NonEmpty.fr │ ├── Product.fr │ ├── Stream.fr │ ├── Traversable.fr │ ├── Tree.fr │ ├── TreeMap.fr │ ├── Tuples.fr │ └── wrapper │ │ ├── Boolean.fr │ │ ├── Const.fr │ │ ├── Dual.fr │ │ ├── Endo.fr │ │ ├── Identity.fr │ │ ├── Num.fr │ │ ├── Ord.fr │ │ └── ZipList.fr ├── ide │ └── Utilities.fr ├── java │ ├── Awt.fr │ ├── IO.fr │ ├── Lang.fr │ ├── Net.fr │ ├── Swing.fr │ ├── Util.fr │ ├── lang │ │ ├── Math.fr │ │ ├── Processes.fr │ │ └── Reflect.fr │ ├── swing │ │ └── GroupLayout.fr │ └── util │ │ ├── Concurrent.fr │ │ ├── Jar.fr │ │ ├── Regex.fr │ │ └── Zip.fr ├── lib │ ├── ForkJoin.fr │ ├── Modules.fr │ └── PP.fr ├── prelude │ ├── Math.fr │ ├── Maybe.fr │ ├── PreludeArrays.fr │ ├── PreludeBase.fr │ ├── PreludeDecimal.fr │ ├── PreludeIO.fr │ ├── PreludeList.fr │ ├── PreludeMonad.fr │ └── PreludeText.fr ├── run │ ├── Concurrent.java │ ├── Kind.java │ ├── RunTM.java │ └── STM.java ├── run7 │ ├── Box.java │ ├── Func.java │ ├── Lazy.java │ └── Thunk.java ├── run8 │ ├── Box.java │ ├── Func.java │ ├── Lazy.java │ ├── Thunk.java │ └── Utils.java ├── runtime │ ├── Array.java │ ├── BlackHole.java │ ├── CompilerSupport.java │ ├── GuardFailed.java │ ├── Javac.java │ ├── Meta.java │ ├── NoMatch.java │ ├── Phantom.java │ ├── Ref.java │ ├── Regex9.java │ ├── Runtime.java │ ├── Undefined.java │ └── Value.java ├── system │ ├── Environment.fr │ ├── Exit.fr │ └── Random.fr ├── test │ ├── QuickCheck.fr │ ├── QuickCheckArbitrary.fr │ ├── QuickCheckException.fr │ ├── QuickCheckGen.fr │ ├── QuickCheckModifiers.fr │ ├── QuickCheckProperty.fr │ ├── QuickCheckState.fr │ ├── QuickCheckTest.fr │ └── QuickCheckText.fr └── tools │ ├── Doc.fr │ ├── MakeDocIndex.fr │ ├── Quick.fr │ ├── Splitter.fr │ ├── YYgen.fr │ ├── YYgenparM-fr │ ├── doc │ └── Utilities.fr │ ├── fregedoc.html │ └── yygenpar-fr ├── resources ├── Frege_logo.jpg ├── Frege_logo.png ├── Frege_logo.svg ├── Frege_logo_flat_colours.jpg ├── Frege_logo_flat_colours.png └── Frege_logo_flat_colours.svg ├── scripts ├── frege.bat ├── fregec.bat ├── genF.pl ├── genFun.pl ├── genFunc.pl ├── genLam.pl ├── genP.pl ├── genProd.pl ├── lein-deploy.sh ├── mkdist.pl ├── mkmk.pl ├── mkversion.pl └── savejava.pl └── tests ├── comp ├── Annotations.java ├── Dezi.fr ├── I61Java.java ├── Issue103.fr ├── Issue126.fr ├── Issue152.fr ├── Issue158.fr ├── Issue160.fr ├── Issue169.fr ├── Issue20.fr ├── Issue203.fr ├── Issue21.fr ├── Issue234.fr ├── Issue257.fr ├── Issue258.fr ├── Issue26.fr ├── Issue260.fr ├── Issue270.fr ├── Issue271.fr ├── Issue273.fr ├── Issue277.fr ├── Issue277a.fr ├── Issue278.fr ├── Issue284.fr ├── Issue284a.fr ├── Issue290.fr ├── Issue294.fr ├── Issue296.fr ├── Issue297.fr ├── Issue298.fr ├── Issue301.fr ├── Issue313.fr ├── Issue323.fr ├── Issue332.fr ├── Issue333.fr ├── Issue336.fr ├── Issue345.fr ├── Issue355.fr ├── Issue357.fr ├── Issue358.fr ├── Issue362.fr ├── Issue47.fr ├── Issue55.fr ├── Issue58.fr ├── Issue61.fr ├── Issue65.fr ├── Issue66.fr ├── Issue67.fr ├── Issue68.fr ├── Issue69.fr ├── Issue80.fr ├── TDNR.fr └── Underscore.fr ├── hcm ├── Bool.fr ├── Identifiers.fr ├── IdentifiersImport.fr ├── Lambda.fr ├── Layout.fr ├── Lexical.fr ├── NoModuleExplicit.fr └── NoModuleLayout.fr ├── messages └── Case1.fr ├── nocomp ├── Issue102.fr ├── Issue125.fr ├── Issue286.fr ├── Issue293.fr ├── Issue348.fr ├── Issue47a.fr ├── Issue47b.fr └── Issue53.fr └── qc ├── Array.fr ├── Decimals.fr ├── Environment.fr ├── Exit.fr ├── HM.fr ├── Ix.fr ├── JSON.fr ├── Map.fr ├── MonoidTest.fr ├── Parser.fr ├── PierresPrime.fr ├── PreludeArraysProp.fr ├── PreludeProperties.fr ├── Record.fr ├── Regexes.fr ├── StringTest.fr ├── Targets.fr └── Wrappers.fr /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | text=auto 3 | 4 | *.jar binary 5 | *.png binary 6 | *.jpg binary 7 | *.jpeg binary 8 | *.ico binary 9 | *.class binary 10 | 11 | *.pl text 12 | *.fr text 13 | *.java text 14 | *.y text 15 | Makefile text 16 | *.mk text 17 | 18 | # Custom for Visual Studio 19 | *.cs diff=csharp 20 | *.sln merge=union 21 | *.csproj merge=union 22 | *.vbproj merge=union 23 | *.fsproj merge=union 24 | *.dbproj merge=union 25 | 26 | # Standard to msysgit 27 | *.doc diff=astextplain 28 | *.DOC diff=astextplain 29 | *.docx diff=astextplain 30 | *.DOCX diff=astextplain 31 | *.dot diff=astextplain 32 | *.DOT diff=astextplain 33 | *.pdf diff=astextplain 34 | *.PDF diff=astextplain 35 | *.rtf diff=astextplain 36 | *.RTF diff=astextplain 37 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ########################## 2 | # those should be ignored 3 | ########################## 4 | *~ 5 | .DS_Store 6 | *.class 7 | *.jar 8 | pg.conf 9 | pgapp.conf 10 | frege.mk 11 | makedoc 12 | dist/ 13 | build/ 14 | build6/ 15 | save/ 16 | doc/*.html 17 | doc/frege/ 18 | doc/resources/ 19 | doc/*.css 20 | doc/package-list 21 | ### latex stuff 22 | doc/Language.aux 23 | doc/Language.idx 24 | doc/Language.ilg 25 | doc/Language.ind 26 | doc/Language.lof 27 | doc/Language.log 28 | doc/Language.lot 29 | doc/Language.out 30 | doc/Language.pdf 31 | doc/Language.synctex.gz 32 | doc/Language.toc 33 | doc/Language.dvi 34 | doc/Language.bbl 35 | doc/Language.blg 36 | doc/Language.synctex.gz 37 | doc/_minted-Language/ 38 | ### frege sources generated in the course of compiler making 39 | frege/Version.fr 40 | ### some people don't have a berkely yacc and are happy to find it in the repo, so let it be there 41 | # frege/compiler/grammar/Frege.fr 42 | ### Misc 43 | y.* 44 | frege/Scrap.fr 45 | shadow/META-INF/ 46 | lib/ 47 | 48 | ################# 49 | ## Eclipse 50 | ################# 51 | 52 | *.pydevproject 53 | .metadata 54 | bin/ 55 | tmp/ 56 | *.tmp 57 | *.bak 58 | *.swp 59 | *~.nib 60 | local.properties 61 | 62 | .settings/ 63 | .loadpath 64 | 65 | # External tool builders 66 | .externalToolBuilders/ 67 | 68 | # Locally stored "Eclipse launch configurations" 69 | *.launch 70 | 71 | # CDT-specific 72 | .cproject 73 | 74 | # PDT-specific 75 | .buildpath 76 | 77 | 78 | ############ 79 | ## Intellij 80 | ############ 81 | 82 | .idea 83 | *.iml 84 | 85 | ############ 86 | ## Gradle 87 | ############ 88 | 89 | .gradle 90 | 91 | ############ 92 | ## Windows 93 | ############ 94 | 95 | # Windows image file caches 96 | Thumbs.db 97 | 98 | # Folder config file 99 | Desktop.ini 100 | 101 | 102 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: java 2 | 3 | jdk: 4 | - openjdk11 5 | 6 | # addons: 7 | # apt: 8 | # packages: 9 | # - oracle-java9-installer 10 | 11 | before_install: 12 | - sudo apt-get update -qq 13 | - sudo apt-get install -y byacc 14 | 15 | before_script: 16 | - mkdir -p build dist doc 17 | # Get the latest fregec.jar to compile the compiler 18 | - curl -L -o fregec.jar https://github.com/Frege/frege/releases/download/3.25alpha/frege3.25.84.jar 19 | 20 | script: 21 | - make compiler1 22 | -------------------------------------------------------------------------------- /build-instructions.md: -------------------------------------------------------------------------------- 1 | Latest build instructions are available under 2 | [Contributing to Frege](https://github.com/Frege/frege/wiki/Contributing-to-Frege) wiki page. -------------------------------------------------------------------------------- /contrib/dgronau/Alternative.fr: -------------------------------------------------------------------------------- 1 | package frege.control.Alternative where 2 | 3 | --import frege.prelude.PreludeMonad 4 | --import frege.control.Monoid 5 | 6 | infixl 3 `<|>` 7 | 8 | class Alternative (Empty f, Applicative f) => f where 9 | (<|>) :: f a -> f a -> f a 10 | 11 | {- 12 | -- | One or more. 13 | some :: f a -> f [a] 14 | some v = some_v 15 | where 16 | many_v = some_v <|> pure [] 17 | some_v = (:) <$> v <*> many_v 18 | 19 | -- | Zero or more. 20 | many :: f a -> f [a] 21 | many v = many_v 22 | where 23 | many_v = some_v <|> pure [] 24 | some_v = (:) <$> v <*> many_v 25 | -} 26 | 27 | -- instances for Prelude types 28 | 29 | --instance Empty Maybe where 30 | -- empty = Nothing 31 | -- null Nothing = true 32 | -- null _ = false 33 | 34 | --instance Alternative Maybe where 35 | -- Nothing <|> p = p 36 | -- Just x <|> _ = Just x 37 | 38 | --instance Alternative [] where 39 | -- (<|>) = (++) 40 | 41 | -- new instances 42 | 43 | --data Const a b = Const { getConst :: a } 44 | 45 | --instance Functor Const m where 46 | -- fmap _ (Const v) = Const v 47 | 48 | --instance Applicative (Monoid m) => Const m where 49 | -- return _ = Const mempty 50 | -- Const f <*> Const v = Const (f `mappend` v) 51 | 52 | 53 | -- | Lists, but with an 'Applicative' functor based on zipping, so that 54 | -- 55 | -- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@ 56 | -- 57 | --data ZipList a = ZipList { getZipList :: [a] } 58 | 59 | --instance Functor ZipList where 60 | -- fmap f (ZipList xs) = ZipList (map f xs) 61 | 62 | --instance Applicative ZipList where 63 | -- return x = ZipList (repeat x) 64 | -- ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs) 65 | 66 | -- | One or none. 67 | --optional :: Alternative f => f a -> f (Maybe a) 68 | --optional v = fmap Just v <|> return Nothing 69 | -------------------------------------------------------------------------------- /contrib/dgronau/Floating.fr: -------------------------------------------------------------------------------- 1 | -- «¦•»«¦•»«¦•»«¦•»«¦•»«¦•»«¦•»«¦•»«¦•»«¦•»«¦•»«¦•»«¦•»«¦•»«¦•»«¦•» 2 | {- 3 | $Author$ 4 | $Revision$ 5 | $Id$ 6 | $Date$ 7 | -} 8 | 9 | --- Contributed by Daniel Gronau 10 | 11 | protected package frege.prelude.Floating where 12 | 13 | import frege.prelude.PreludeBase 14 | import frege.prelude.Math() 15 | 16 | class Floating Real a => a where 17 | pi :: a 18 | exp, log, sqrt :: a -> a 19 | (**), logBase :: a -> a -> a 20 | sin, cos, tan :: a -> a 21 | asin, acos, atan :: a -> a 22 | sinh, cosh, tanh :: a -> a 23 | asinh, acosh, atanh :: a -> a 24 | x ** y = exp (log x * y) 25 | logBase x y = log y / log x 26 | tan x = sin x / cos x 27 | tanh x = sinh x / cosh x 28 | 29 | instance Floating Double where 30 | pi = Math.pi 31 | asinh x = Floating.log (x + Floating.sqrt (1.0 + x*x)) 32 | acosh x = Floating.log (x + (x + 1.0) * Floating.sqrt ((x - 1.0)/(x + 1.0))) 33 | atanh x = 0.5 * Floating.log ((1.0 + x) / (1.0 - x)) 34 | -- the following 3 can't be inherited because Double.**, Double.tan and Double.tanh 35 | -- already exist as native functions and would be inherited from there 36 | x ** y = exp (log x * y) 37 | tan x = sin x / cos x 38 | tanh x = sinh x / cosh x 39 | 40 | instance Floating Float where 41 | pi = Math.pi.float 42 | -- the following 3 can't be inherited because Float.**, Float.tan and Float.tanh 43 | -- already exist as native functions and would be inherited from there 44 | x ** y = exp (log x * y) 45 | tan x = sin x / cos x 46 | tanh x = sinh x / cosh x 47 | acos f = (Float.acos f).float 48 | asin f = (Float.asin f).float 49 | atan f = (Float.atan f).float 50 | cosh f = (Float.cosh f).float 51 | sinh f = (Float.sinh f).float 52 | sqrt f = (Float.sqrt f).float 53 | cos f = (Float.cos f).float 54 | exp f = (Float.exp f).float 55 | log f = (Float.log f).float 56 | sin f = (Float.sin f).float 57 | asinh x = Floating.log (x + Floating.sqrt (1.0f + x*x)) 58 | acosh x = Floating.log (x + (x + 1.0f) * Floating.sqrt ((x - 1.0f)/(x + 1.0f))) 59 | atanh x = 0.5f * Floating.log ((1.0f + x) / (1.0f - x)) 60 | 61 | -------------------------------------------------------------------------------- /contrib/dgronau/Monadic.fr: -------------------------------------------------------------------------------- 1 | -- «•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•» 2 | 3 | {- 4 | Contributed by: Daniel Gronau 5 | last committed by $Author$ 6 | $Revision$ 7 | $Id$ 8 | $Date$ 9 | -} 10 | 11 | 12 | package test.Test where 13 | 14 | import frege.Prelude P ($) 15 | 16 | infixl 4 `<$>` `<*>` --`<*` `*>` `<**>` `<$` 17 | 18 | main _ = P.println $ (P.`+`) <$> Just 10 <*> Just 4 19 | 20 | 21 | class Functor this where 22 | fmap,(<$>) :: (a -> b) -> this a -> this b 23 | f <$> x = fmap f x 24 | 25 | class Apply Functor this => this where 26 | ap,(<*>) :: this (a -> b) -> this a -> this b 27 | f <*> x = ap f x 28 | 29 | class Applicative Apply this => this where 30 | return :: a -> this a 31 | fmap f x = return f <*> x 32 | 33 | class Bind Apply this => this where 34 | (>>=) :: this a -> (a -> this b) -> this b 35 | (>>) :: this a -> this b -> this b 36 | a >> b = a >>= P.const b 37 | 38 | -- apx mf mx = mf >>= (\f -> mx >>= (\x -> return (f x))) 39 | 40 | class Monad (Applicative this, Bind this) => this where 41 | ap mf mx = mf >>= (\f -> mx >>= (\x -> return (f x))) 42 | fail :: P.String -> this a 43 | fail s = P.error s 44 | 45 | data Maybe a = Nothing | Just a 46 | 47 | derive P.Show Maybe a 48 | 49 | instance Monad Maybe where 50 | return a = Just a 51 | Nothing >>= _ = Nothing 52 | Just a >>= k = k a 53 | fail s = Nothing 54 | -------------------------------------------------------------------------------- /contrib/dgronau/arrow/Category.fr: -------------------------------------------------------------------------------- 1 | package frege.control.Category where 2 | 3 | infixr 1 `>>>` `<<<` 4 | 5 | class Semigroupoid c where 6 | --- morphism composition 7 | o :: c j k -> c i j -> c i k 8 | 9 | {-- 10 | A class for categories. 11 | identity and o must form a monoid. 12 | -} 13 | class Category Semigroupoid c => c where 14 | --- the identity morphism 15 | identity :: c a a 16 | 17 | -- function wrapper 18 | -- TODO replace when function-as-instance feature is available 19 | data F a b = F { run :: (a -> b) } 20 | 21 | instance Semigroupoid F where 22 | f `o` g = F (F.run f <~ F.run g) 23 | 24 | instance Category F where 25 | identity = F id 26 | 27 | --- Right-to-left composition 28 | (<<<) :: Semigroupoid cat => cat b c -> cat a b -> cat a c 29 | (<<<) = o 30 | 31 | --- Left-to-right composition 32 | (>>>) :: Semigroupoid cat => cat a b -> cat b c -> cat a c 33 | f >>> g = g `o` f -------------------------------------------------------------------------------- /contrib/dgronau/trans/EitherT.fr: -------------------------------------------------------------------------------- 1 | package frege.control.trans.EitherT where 2 | 3 | import frege.Prelude (Monad, Applicative, Functor, Either, $, <~, liftM, id) 4 | import frege.control.Monoid 5 | import frege.control.trans.MonadTrans 6 | import frege.control.trans.MonadIO 7 | 8 | data EitherT l m a = EitherT { run :: m (Either l a) } 9 | 10 | 11 | inEitherT0 :: m (Either l a) -> EitherT l m a 12 | inEitherT0 x = EitherT x 13 | inEitherT1 :: (m (Either l a) -> m (Either l b)) -> 14 | EitherT l m a -> EitherT l m b 15 | inEitherT1 f x = inEitherT0 $ f $ EitherT.run x 16 | inEitherT2 :: (m (Either l a) -> m (Either l b) -> m (Either l c)) -> 17 | EitherT l m a -> EitherT l m b -> EitherT l m c 18 | inEitherT2 f x y = inEitherT1 (f $ EitherT.run x) y 19 | 20 | left :: Monad m => l -> EitherT l m a 21 | left x = EitherT $ return $ Left x 22 | 23 | instance Monad Monad m => (EitherT l m) where 24 | -- We can't support "fail" because we don't have a 25 | -- (String -> l). But we can at least make it a Left, with the error inside 26 | -- it as a pure exception. 27 | --fail = EitherT . return . Left . error 28 | return x = EitherT $ return $ Right x 29 | EitherT x >>= f = EitherT $ do 30 | res <- x 31 | case res of 32 | Right r -> EitherT.run $ f $ r 33 | Left l -> return (Left l) 34 | 35 | instance MonadTrans (EitherT l) where 36 | lift x = EitherT $ liftM Right x 37 | {- 38 | instance Functor Functor f => (EitherT l) f where 39 | fmap = inEitherT1 <~ fmap <~ fmap 40 | 41 | 42 | instance Applicative Applicative f => (EitherT l) f where 43 | return x = EitherT $ return $ Right x 44 | (<*>) = inEitherT2 <~ liftA2 <~ liftA2 $ id 45 | 46 | private liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c 47 | private liftA2 f a b = f `fmap` a <*> b 48 | -} 49 | instance MonadIO MonadIO m => EitherT l m where 50 | liftIO = lift <~ liftIO 51 | 52 | {- 53 | instance Monoid (Applicative m, Monoid a) => EitherT l m a where 54 | mempty = return mempty 55 | mappend = liftA2 mappend 56 | -} -------------------------------------------------------------------------------- /contrib/dgronau/trans/MaybeT.fr: -------------------------------------------------------------------------------- 1 | package frege.control.trans.MaybeT where 2 | 3 | import frege.control.trans.MonadTrans 4 | import frege.control.trans.MonadIO 5 | 6 | {-- 7 | The parameterizable maybe monad, obtained by composing an arbitrary 8 | monad with the 'Maybe' monad. 9 | 10 | Computations are actions that may produce a value or fail. 11 | 12 | The 'return' function yields a successful computation, while (>>=) 13 | sequences two subcomputations, failing on the first error. 14 | -} 15 | data MaybeT m a = MaybeT { run :: m (Maybe a) } 16 | 17 | -- | Transform the computation inside a @MaybeT@. 18 | mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b 19 | mapMaybeT f mt = MaybeT $ f $ MaybeT.run mt 20 | 21 | instance Functor Functor m => MaybeT m where 22 | fmap f = mapMaybeT (fmap (fmap f)) 23 | 24 | --instance (Functor m, Monad m) => Alternative (MaybeT m) where 25 | -- empty = mzero 26 | -- (<|>) = mplus 27 | 28 | instance Monad Monad m => MaybeT m where 29 | --fail _ = MaybeT (return Nothing) 30 | return mt = lift $ return mt 31 | x >>= f = MaybeT $ do 32 | v <- MaybeT.run x 33 | case v of 34 | Nothing -> return Nothing 35 | Just y -> MaybeT.run (f y) 36 | 37 | instance MonadFail Monad m => MaybeT m where 38 | fail _ = MaybeT (return Nothing) 39 | 40 | instance MonadPlus Monad m => MaybeT m where 41 | mzero = MaybeT (return Nothing) 42 | mplus x y = MaybeT $ do 43 | v <- MaybeT.run x 44 | case v of 45 | Nothing -> MaybeT.run y 46 | Just _ -> return v 47 | 48 | instance MonadTrans MaybeT where 49 | lift mt = MaybeT $ liftM Just mt 50 | 51 | instance MonadIO MonadIO m => MaybeT m where 52 | liftIO io = lift $ liftIO io -------------------------------------------------------------------------------- /contrib/dgronau/trans/MonadIO.fr: -------------------------------------------------------------------------------- 1 | package frege.control.trans.MonadIO where 2 | 3 | {-- 4 | Monads in which 'IO' computations may be embedded. 5 | Any monad built by applying a sequence of monad transformers to the 6 | 'IO' monad will be an instance of this class. 7 | 8 | Instances should satisfy the following laws, which state that 'liftIO' 9 | is a transformer of monads: 10 | 11 | 'liftIO' <~ 'return' = 'return' 12 | 13 | 'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' <~ f) 14 | 15 | -} 16 | 17 | class MonadIO Monad m => m where 18 | --- Lift a computation from the 'IO' monad. 19 | liftIO :: IO a -> m a 20 | 21 | instance MonadIO IO where 22 | liftIO io = io 23 | return = ST.return 24 | (>>=) = (ST.>>=) -------------------------------------------------------------------------------- /contrib/dgronau/trans/MonadTrans.fr: -------------------------------------------------------------------------------- 1 | package frege.control.trans.MonadTrans where 2 | 3 | class MonadTrans t where 4 | --- Lift a computation from the argument monad to the constructed monad. 5 | lift :: Monad m => m a -> t m a 6 | -------------------------------------------------------------------------------- /contrib/dgronau/trans/TransTest.fr: -------------------------------------------------------------------------------- 1 | package frege.control.trans.TransTest where 2 | 3 | import frege.control.trans.MaybeT 4 | 5 | main _ = do 6 | MaybeT.run askPassword 7 | return () 8 | 9 | isValid :: String -> Bool 10 | isValid s = length s >= 8 11 | 12 | getValidPassword = do 13 | s <- MaybeT.lift getLine 14 | guard (isValid s) 15 | return s 16 | 17 | askPassword = do 18 | MaybeT.lift $ putStrLn "Insert your new password:" 19 | value <- msum $ repeat getValidPassword 20 | MaybeT.lift $ putStrLn "Storing in database..." 21 | 22 | putStrLn :: String -> IO () 23 | putStrLn s = println s 24 | 25 | native systemInRead "java.lang.System.in.read" :: () -> IO (Exception Int) 26 | 27 | getChar :: IO Char 28 | getChar = do 29 | (Right i) <- systemInRead () 30 | return $ chr i 31 | 32 | getLine :: IO String 33 | getLine = go [] where 34 | go acc = do 35 | c <- getChar 36 | if c == '\n' then return (packed $ reverse acc) else go (c:acc) 37 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | # makefile for frege docu 2 | # $Revision$ 3 | # $Header: E:/iwcvs/fc/doc/Makefile,v 1.4 2010/10/21 14:28:00 ingo Exp $ 4 | # $Log: Makefile,v $ 5 | # Revision 1.4 2010/10/21 14:28:00 ingo 6 | # make all commands quite 7 | # 8 | # Revision 1.3 2007/10/01 16:17:01 iw 9 | # - new chapters 10 | # 11 | # Revision 1.2 2007/09/29 17:56:12 iw 12 | # - index and bibliography 13 | # 14 | # Revision 1.1 2007/09/22 16:01:24 iw 15 | # - documentation 16 | # 17 | # Revision 1.3 2007/09/21 16:40:27 iw 18 | # - compiler compiled by the java compiler compiles itself 19 | # 20 | # Revision 1.2 2006/11/12 14:49:16 iw 21 | # - implemented layout 22 | # 23 | # Revision 1.1 2006/05/21 18:00:17 iw 24 | # CVS on memorystick 25 | # 26 | # Revision 1.2 2006/05/20 14:02:41 iw 27 | # make all makes Docu.pdf and Doku.dvi 28 | # 29 | 30 | CHAPTERS = chaptertypes.tex chaptermodules.tex chapterdeclarations.tex \ 31 | chapterlex.tex chapterexpr.tex chapternative.tex chapterio.tex 32 | 33 | IMAGES = utfcode.eps 34 | 35 | LATEX = latex 36 | 37 | all: Language.pdf Implementation.pdf 38 | 39 | Language.ps: Language.dvi 40 | dvips Language 41 | 42 | Language.pdf: Language.dvi 43 | dvipdfm -q Language 44 | 45 | Language.dvi: Language.tex $(CHAPTERS) $(IMAGES) 46 | $(LATEX) -interaction batchmode Language.tex 47 | $(LATEX) -interaction batchmode Language.tex 48 | $(LATEX) -interaction batchmode Language.tex 49 | makeindex Language 50 | $(LATEX) -interaction batchmode Language.tex 51 | 52 | Implementation.ps: Implementation.dvi 53 | dvips Implementation 54 | 55 | Implementation.pdf: Implementation.dvi 56 | dvipdfm -q Implementation 57 | 58 | Implementation.dvi: Implementation.tex 59 | latex -interaction batchmode -quiet Implementation.tex 60 | 61 | # utfcode.eps: utfcode.pnm 62 | # pnmtops -nocenter -dpi 72 -noturn -rle utfcode.pnm > utfcode.eps 63 | # 64 | #utfcode.pnm: utfcode.TIF 65 | # tifftopnm utfcode.tif >utfcode.pnm 66 | 67 | Test.ps: Test.dvi 68 | dvips Test 69 | 70 | Test.pdf: Test.dvi 71 | dvipdfm -q Test 72 | 73 | Test.dvi: Test.tex 74 | latex -interaction batchmode -quiet Test.tex 75 | 76 | test: Test.pdf 77 | -------------------------------------------------------------------------------- /doc/chapterio.tex: -------------------------------------------------------------------------------- 1 | \chapter{Input/Output} 2 | 3 | \todo{write it} -------------------------------------------------------------------------------- /examples/Brainfuck.fr: -------------------------------------------------------------------------------- 1 | package examples.Brainfuck where 2 | 3 | import frege.Prelude hiding (uncons) 4 | import frege.data.List(lookup) 5 | 6 | data Tape = Tape { left :: [Int], cell :: Int, right :: [Int] } 7 | 8 | instance Show Tape where 9 | show (Tape ls c rs) = show [reverse ls,[c],rs] 10 | 11 | data Op = Plus | Minus | GoLeft | GoRight | Output | Input | Loop [Op] 12 | 13 | derive Eq Op 14 | derive Show Op 15 | 16 | -- the parser 17 | 18 | removeComments :: [Char] -> [Char] 19 | removeComments xs = filter (`elem` (unpacked "+-<>.,[]")) xs 20 | 21 | ops = [('+', Plus),('-', Minus),('<',GoLeft),('>',GoRight),('.',Output),(',',Input)] 22 | 23 | parseOp :: [Char] -> Maybe (Op, [Char]) 24 | parseOp ('[':cs) = case parseOps cs of 25 | (prog, (']':cs')) -> Just (Loop prog, cs') 26 | _ -> Nothing 27 | parseOp (c:cs) = fmap (flip (,) cs) $ lookup c ops 28 | parseOp [] = Nothing 29 | 30 | parseOps :: [Char] -> ([Op],[Char]) 31 | parseOps cs = go cs [] where 32 | go cs acc = case parseOp cs of 33 | Nothing -> (reverse acc, cs) 34 | Just (op, cs') -> go cs' (op:acc) 35 | 36 | parse :: String -> [Op] 37 | parse prog = case parseOps $ removeComments $ unpacked prog of 38 | (ops, []) -> ops 39 | (ops, rest) -> error $ "Parsed: " ++ show ops ++ ", Rest: " ++ packed rest 40 | 41 | -- the interpreter 42 | 43 | execute :: [Op] -> Tape -> IO Tape 44 | execute prog tape = foldM exec tape prog where 45 | exec :: Tape -> Op -> IO Tape 46 | exec tape Plus = return $ tape.{cell <- succ} 47 | exec tape Minus = return $ tape.{cell <- pred} 48 | exec (Tape ls c rs) GoLeft = let (hd,tl) = uncons ls in return $ Tape tl hd (c:rs) 49 | exec (Tape ls c rs) GoRight = let (hd,tl) = uncons rs in return $ Tape (c:ls) hd tl 50 | exec tape Output = printAsChar tape.cell >> return tape 51 | exec tape Input = do n <- getChar; return tape.{cell = ord n} 52 | exec tape (again @ Loop loop) 53 | | tape.cell == 0 = return tape 54 | | otherwise = execute loop tape >>= flip exec again 55 | 56 | -- helper functions 57 | 58 | private uncons :: [Int] -> (Int,[Int]) 59 | private uncons [] = (0,[]) 60 | private uncons (x:xs) = (x,xs) 61 | 62 | 63 | 64 | private printAsChar :: Int -> IO () 65 | private printAsChar i = print $ packed [Char.from i] 66 | 67 | -- execution environment 68 | 69 | run :: String -> IO Tape 70 | run prog = execute (parse prog) (Tape [] 0 []) 71 | 72 | main _ = do 73 | tape <- run helloWorld 74 | println "" 75 | println tape 76 | 77 | -- example programs 78 | 79 | helloWorld = 80 | ">+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++" ++ 81 | "[<++++>-]<.>+++++++++++[<+++++>-]<.>++++++++[<+++>-]<.+++.------.--------." ++ 82 | "[-]>++++++++[<++++>-]<+.[-]++++++++++." 83 | 84 | nineToZero = 85 | "++++++++++++++++++++++++++++++++[>+>+<<-]" ++ 86 | ">>+++++++++++++++++++++++++<<++++++++++[>>.-<.<-]" -------------------------------------------------------------------------------- /examples/CommandLineClock.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | This program displays the 3 | current time on standard output 4 | every other second. 5 | -} 6 | 7 | module examples.CommandLineClock where 8 | 9 | data Date = native java.util.Date where 10 | native new :: () -> IOMutable Date -- new Date() 11 | | Long -> STMutable s Date -- new Date(123) 12 | native toString :: Mutable s Date -> ST s String -- d.toString() 13 | 14 | --- 'IO' action to give us the current time as 'String' 15 | current :: IO String 16 | current = do 17 | d <- Date.new () 18 | d.toString 19 | 20 | {- 21 | "java.lang.Thread.sleep" takes a "long" and 22 | returns nothing, but may throw an InterruptedException. 23 | This is without doubt an IO action. 24 | 25 | public static void sleep(long millis) 26 | throws InterruptedException 27 | 28 | Encoded in Frege: 29 | - argument type long Long 30 | - result void () 31 | - does IO IO () 32 | - throws ... throws .... 33 | 34 | -} 35 | -- .... defined in frege.java.Lang 36 | -- native sleep java.lang.Thread.sleep :: Long -> IO () throws InterruptedException 37 | 38 | main args = 39 | forever do 40 | current >>= print 41 | print "\r" 42 | stdout.flush 43 | Thread.sleep 999 44 | -------------------------------------------------------------------------------- /examples/Diverge.fr: -------------------------------------------------------------------------------- 1 | --- This is to show how the type checker helps detect an infinite loop 2 | --- Adapted for Frege from Mark Jason Dominus talk 3 | --- 'http://perl.plover.com/yak/typing/ Strong Typing and Perl' which uses ML 4 | module examples.Diverge where 5 | 6 | 7 | --- split a list 8 | split ∷ [α] → ([α],[α]) 9 | split [] = ([], []) 10 | split (a1:a2:as) = (a1:bs, a2:cs) 11 | where (bs, cs) = split as 12 | -- when commenting the next line, we get a warning that the 13 | -- case for the singleton list is missing 14 | split singleton = (singleton, []) 15 | 16 | --- merge two already sorted lists 17 | merge ∷ Ord α ⇒ [α] → [α] → [α] 18 | merge [] bs = bs 19 | merge (a:as) (b:bs) 20 | | a <= b = a : merge as (b:bs) 21 | | otherwise = b : merge (a:as) bs 22 | merge (as@_:_) [] = as 23 | 24 | {-- 25 | sort a list by splitting it into two smaller ones, 26 | and merging the sorted smaller lists. 27 | 28 | When we forget the singleton case (the second equation), 29 | the type becomes 30 | > Ord b => [a] -> [b] 31 | 32 | In English, this means: If you pass any list to 'sort', 33 | it will return a list of any type you want, provided only 34 | that values of that type can be ordered. In addition, 35 | it doesn't even care if the values in your list can be ordered. 36 | 37 | How is that possible? 38 | 39 | It is possible only in two cases: 40 | - you pass the empty list, and get back a properly typed empty list 41 | - you pass a non-empty list, but the function does not actually return. 42 | Nor will it actually sort the elements in the empty list. 43 | 44 | Consider: 45 | [A] If sort returns, you get a list of arbitrarily typed elements. 46 | [B] But it can't possibly make a list of arbitrarily typed elements! 47 | [A] Right! But "ex falso quod libet". Hence, it won't return. 48 | 49 | In fact, suppose the evaluation of 50 | > sort [1] 51 | The list gets splitted to 52 | > ([1], []) 53 | and the result is 54 | > merge (sort [1]) (sort []) 55 | And since we now know that 56 | > sort [1] = merge (sort [1]) (sort []) 57 | it follows that 58 | > merge (sort [1]) (sort []) = merge (merge (sort [1]) (sort [])) (sort []) 59 | and so forth. 60 | -} 61 | -- sort :: Ord e => [e] -> [e] 62 | sort [] = [] 63 | -- sort [a] = [a] 64 | sort xs = merge (sort as) (sort bs) 65 | where (as, bs) = split xs 66 | 67 | --- will only type check as long as 'sort' is not fixed 68 | foo :: ([Double], [Bool]) 69 | foo = (sort ["how", "so"], sort ["this", "is", "impossible"]) -------------------------------------------------------------------------------- /examples/Euler12.fr: -------------------------------------------------------------------------------- 1 | --- Solve 'http://projecteuler.net/index.php?section=problems&id=12 Euler problem 12' in less than a second. 2 | --- The original question asks for the first triangular number with at least 500 divisors. 3 | 4 | module examples.Euler12 where 5 | 6 | import examples.EulerLib 7 | import Data.List 8 | import frege.test.QuickCheck 9 | 10 | --- compute number of divisors from prime factors combinatorically 11 | nDivisors :: Long -> Int 12 | nDivisors = prod . map ((1+) . length) . group . factors 13 | 14 | --- check that 'nDivisors' works properly 15 | property_nDivisors = property law 16 | where 17 | -- law :: Long -> Property 18 | law n = (classify (n==0) "trivial" $ 19 | n == 0 || nDivisors (abs n) == length (divisors (abs n))) 20 | 21 | 22 | main [arg] = println . head . dropUntil ((n<) . nDivisors) . scanl1 (+) $ [1..] 23 | where 24 | n = atoi arg 25 | main _ = main ["500"] -------------------------------------------------------------------------------- /examples/Euler7.fr: -------------------------------------------------------------------------------- 1 | --- print prime numbers 2 | 3 | package examples.Euler7 where 4 | 5 | import examples.EulerLib 6 | 7 | 8 | --- give some integers > 0 9 | main :: [String] -> IO () 10 | main = println 11 | • map (either (const (-1n)) ((primes !!) • (subtract 1))) -- get corresponding prime 12 | • filter (either (const false) (>0)) -- make sure its right and > 0 13 | • map String.int -- [String] -> [Exception Int] 14 | -------------------------------------------------------------------------------- /examples/Euler87.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | The smallest number expressible as the sum of a prime square, 3 | prime cube, and prime fourth power is 28. 4 | In fact, there are exactly four numbers below fifty that can be expressed 5 | in such a way: 6 | 7 | 28 = 2² + 2³ + 2⁴ 8 | 33 = 3² + 2³ + 2⁴ 9 | 49 = 5² + 2³ + 2⁴ 10 | 47 = 2² + 3³ + 2⁴ 11 | 12 | How many numbers below fifty million can be expressed as the sum of a prime 13 | square, prime cube, and prime fourth power? 14 | -} 15 | 16 | module examples.Euler87 where 17 | 18 | -- import Data.Tuples 19 | import Data.TreeMap 20 | import examples.EulerLib 21 | -- import frege.prelude.Floating 22 | 23 | -- 1097343 24 | -- runtime 19.485 wallclock seconds. 25 | -- Level 3 Rank 355 26 | 27 | limit = 50_000_000 28 | 29 | main _ = do 30 | -- sequence_ (map println sums) 31 | println (length (keys (fromKeys sums))) 32 | where 33 | sums = [ sum | 34 | p4 <- p4s, p3 <- p3s, 35 | p3 + p4 < limit, 36 | p2 <- takeWhile (< limit-p4-p3) p2s, 37 | let !sum = p2+p3+p4 38 | ] 39 | sqr :: Int -> Int 40 | sqr n = n*n 41 | sqr3 :: Int ->Int 42 | sqr3 n = n*n*n 43 | -- the list of prime fourth powers below the limit 44 | p4s = takeWhile ( loop (acc + r*r) (k `quot` 10) 58 | 59 | --- the sum of the squares in the input list 60 | sqsum xs = sqsum 0 xs where 61 | sqsum :: Int -> [Int] -> Int 62 | sqsum acc (i:is) = sqsum (acc+(i * i)) is 63 | sqsum acc [] = acc 64 | 65 | --- gets the digits of a positive number and interprets them as integers 66 | digits :: Int -> [Int] 67 | digits = map ichr • unpacked • show 68 | where 69 | ichr :: Char -> Int 70 | ichr c = ord c - ord '0' 71 | 72 | --- gives a representation of the number so that smaller numbers come first 73 | --- e.g. 1024 -> 124 74 | canonic n = fold (\a \n -> a * 10L + Int.long n) 0L (sort (digits n)) 75 | 76 | --- make sure that 'squaresum' computes the same as (sqsum•digits) 77 | --- (for positive integers, that is) 78 | prop_sq = property (\k -> let n = abs k in sqsum (digits n) == squaresum n) 79 | -------------------------------------------------------------------------------- /examples/Euler94.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | It is easily proved that no equilateral triangle exists with integral length sides 3 | and integral area. However, the almost equilateral triangle 5-5-6 has an area of 12 square units. 4 | 5 | We shall define an almost equilateral triangle to be a triangle for which two sides are equal 6 | and the third differs by no more than one unit. 7 | 8 | Find the sum of the perimeters of all almost equilateral triangles with integral 9 | side lengths and area and whose perimeters do not exceed one billion (1_000_000_000). 10 | -} 11 | 12 | 13 | -- ???????? 14 | -- runtime 15353.275 wallclock seconds. 15 | -- Clearly outside the 1 minute limit 16 | -- After mathematical expertise applied: runtime 0.144 wallclock seconds. 17 | 18 | module examples.Euler94 where 19 | 20 | import examples.EulerLib 21 | 22 | main _ = do 23 | print "Pell: "; println (take 8 pell) 24 | print "Dreiecke Pell: "; println pTriangles 25 | print "Trans: "; println (take 8 transformed) 26 | print "Dreiecke Trans: "; println tTriangles 27 | print "Solution: " 28 | println ((summe • map perimeter) pTriangles + (summe • map perimeter) tTriangles) 29 | where 30 | -- iterate f x = [x, f x, f (f x), .... ] 31 | pell = iterate (next (2,1)) (2,1) 32 | where 33 | next (m0,n0) (m1,n1) = (m2,n2) 34 | where 35 | m2 = m0*m1 + 3*n0*n1 36 | n2 = n0*m1 + m0*n1 37 | 38 | -- map f [a1, a2, a3, ... ] = [f a1, f a2, f a3, ...] 39 | transformed = map trans pell 40 | where trans (m,n) = (m+2*n, n) 41 | 42 | triaX (m,n) = (2*x, z, z) where x = m*m - n*n; z = m*m + n*n 43 | triaY (m,n) = (2*y, z, z) where y = 2*m*n; z = m*m + n*n 44 | 45 | -- zu große Zahlen können überlaufen, dann ergeben sich negative Werte 46 | -- Wenn a größer als 333.333.334 ist, wird der Umfang zu groß 47 | valid (a,_,_) = a > 0 && a <= 333_333_334 48 | perimeter (a,b,c) = a+b+c 49 | pTriangles = takeWhile valid (map triaX pell) 50 | tTriangles = takeWhile valid (map triaY transformed) 51 | 52 | 53 | 54 | 55 | -------------------------------------------------------------------------------- /examples/Evolution.fr: -------------------------------------------------------------------------------- 1 | -- from "http://www.willamette.edu/~fruehr/haskell/evolution.html" 2 | 3 | package examples.Evolution where 4 | 5 | import frege.Prelude hiding(zero, succ, •, id) -- avoid warnings 6 | import Control.Semigroupoid 7 | import Control.Category 8 | 9 | --- explicit type recursion with functors and catamorphisms 10 | data Mu f = !In (f (Mu f)) 11 | 12 | unIn (In x) = x 13 | 14 | cata phi = phi • fmap (cata phi) • unIn 15 | 16 | 17 | -- base functor and data type for natural numbers, 18 | -- using locally-defined "eliminators" 19 | 20 | data N c = Z | S c 21 | 22 | instance Functor N where 23 | fmap g Z = Z 24 | fmap g (S x) = S (g x) 25 | 26 | type Nat a = Mu (N a) 27 | 28 | zero = In Z 29 | succ n = In (S n) 30 | 31 | add m = cata phi where 32 | phi Z = m 33 | phi (S f) = succ f 34 | 35 | mult m = cata phi where 36 | phi Z = zero 37 | phi (S f) = add m f 38 | 39 | 40 | -- explicit products and their functorial action 41 | 42 | data Prod e c = Pair c e 43 | 44 | outl (Pair x y) = x 45 | outr (Pair x y) = y 46 | 47 | fork f g x = Pair (f x) (g x) 48 | 49 | instance Functor (Prod e) where 50 | fmap g = fork (g • outl) outr 51 | 52 | 53 | -- comonads, the categorical "opposite" of monads 54 | 55 | class Functor n => Comonad n where 56 | extr :: n a -> a 57 | dupl :: n a -> n (n a) 58 | 59 | instance Comonad (Prod e) where 60 | extr = outl 61 | dupl = fork id outr 62 | 63 | 64 | -- generalized catamorphisms, zygomorphisms and paramorphisms 65 | 66 | gcata :: (Functor f, Comonad n) => 67 | (forall a. f (n a) -> n (f a)) 68 | -> (f (n c) -> c) -> Mu f -> c 69 | 70 | gcata dist phi = extr • cata (fmap phi • dist • fmap dupl) 71 | 72 | zygo chi = gcata (fork (fmap outl) (chi • fmap outr)) 73 | 74 | para :: Functor f => (f (Prod (Mu f) c) -> c) -> Mu f -> c 75 | para = zygo In 76 | 77 | 78 | --- factorial, the *hard* way! 79 | 80 | fac = para phi where 81 | phi Z = succ zero 82 | phi (S (Pair f n)) = mult f (succ n) 83 | 84 | 85 | -- for convenience and testing 86 | 87 | int = cata phi where 88 | phi Z = 0 89 | phi (S f) = 1 + f 90 | 91 | showmu = show • int 92 | 93 | toMu 0 = zero 94 | toMu n = succ (toMu (n-1)) 95 | 96 | {- 97 | X:\frege3>java -Xss1m -cp build examples.Evolution 98 | 720 99 | runtime 0.063 wallclock seconds. 100 | -} 101 | main [arg] = println $ (showmu . fac . toMu . String.atoi) arg 102 | main _ = println $ showmu (fac (succ (succ (succ (succ (succ (succ zero))))))) 103 | -------------------------------------------------------------------------------- /examples/ForH.fr: -------------------------------------------------------------------------------- 1 | module examples.ForH where 2 | 3 | -- import Data.List 4 | 5 | main _ = print $ take 10 pyth 6 | where 7 | pyth = [ (x, y, m*m+n*n) | 8 | m <- [2..], n <- [1..m-1], 9 | let { x = m*m-n*n; y = 2*m*n }, 10 | ] -------------------------------------------------------------------------------- /examples/FunctionInstances.fr: -------------------------------------------------------------------------------- 1 | --- Tests mit von Daniel angemahnten Dingen 2 | 3 | module examples.FunctionInstances where 4 | 5 | class PrintMulti r where prints :: String -> r 6 | instance PrintMulti String where prints s = s 7 | instance (Show a, PrintMulti r) => PrintMulti (a -> r) where 8 | prints b = prints . (b ++) . show 9 | -- prints b = prints . (show b ++) 10 | 11 | 12 | -- instance Show (a -> b) where show _ = "function" 13 | 14 | -- Funktion mit variabler Zahl von Argumenten, bei SO abgeschrieben 15 | class SumRes r where sumOf :: Integer -> r 16 | instance SumRes Integer where sumOf i = i 17 | 18 | instance (Integral a, SumRes r) => SumRes (a -> r) where 19 | sumOf x = sumOf • (x +) • toInteger 20 | 21 | {- design für Strings mit Phantomtyp Char 22 | type String = StringJ Char 23 | data StringJ char = pure native java.lang.String where 24 | pure native itemAt frege.RT.itemAt :: StringJ a -> Int -> a -- cheat! 25 | pure native literal new :: Prelude.String -> StringJ Char -- for tests only 26 | pure native toString :: StringJ a -> Prelude.String -- for tests only 27 | pure native length :: StringJ a -> Int 28 | pure native substring :: StringJ a -> Int -> Int -> StringJ a 29 | tail ss = substring ss 1 ss.length -- für AbstractList 30 | -- pure native null :: StringJ a -> Bool 31 | 32 | class Head h where head :: h a -> a -- fehlt noch in AbstractList 33 | instance Head StringJ where head s = s.itemAt 0 34 | instance ListSource StringJ where 35 | toList ss | "" <- ss.toString = [] 36 | | otherwise = ss.head : toList ss.tail 37 | -} 38 | 39 | main _ = do 40 | -- println id 41 | let x = prints "a" "b" "c" "d" :: String 42 | println x 43 | return () 44 | 45 | -- println (sumOf 1n 2n 3n :: Integer) 46 | -- (println • head • String.literal) "¿?" 47 | -- (println • toList • String.literal) "Cool" -------------------------------------------------------------------------------- /examples/GoldenRatio.fr: -------------------------------------------------------------------------------- 1 | --- Compute and print the golden ratio 2 | module examples.GoldenRatio where 3 | 4 | import Data.List (dropUntil) 5 | 6 | fibs = 1:1:zipWith (+) fibs (tail fibs) :: [Long] 7 | 8 | infix 6 *** 9 | 10 | (***) n = packed . replicate n 11 | 12 | main _ = do 13 | println ("The golden ratio is " ++ show golden 14 | ++ " = (" ++ show nom ++ "/" ++ show denom ++ ")") 15 | -- print a 48x30 box of stars 16 | replicateM_ 30 (println ((30*golden).long.int *** '*')) 17 | where 18 | golden = nom.double / denom.double 19 | (denom, nom) = head . dropUntil closeEnough . zip fibs $ (tail fibs) 20 | closeEnough (d,n) = abs (a-b) < 1.0e-9 21 | where 22 | b = Long.double n / Long.double d 23 | a = (1+b)/b 24 | 25 | -------------------------------------------------------------------------------- /examples/Grep.fr: -------------------------------------------------------------------------------- 1 | --- A simple grep 2 | module examples.Grep where 3 | 4 | --- exception thrown when an invalid regular expression is compiled 5 | data PatternSyntax = native java.util.regex.PatternSyntaxException 6 | derive Exceptional PatternSyntax 7 | 8 | main [] = stderr.println "Usage: java examples.Grep regex [files ...]" 9 | main (pat:xs) = do 10 | rgx <- return (regforce pat) 11 | case xs of 12 | [] -> grepit rgx stdin 13 | fs -> mapM_ (run rgx) fs 14 | `catch` badpat where 15 | badpat :: PatternSyntax -> IO () 16 | badpat pse = do 17 | stderr.println "The regex is not valid." 18 | stderr.println pse.getMessage 19 | 20 | run regex file = do 21 | rdr <- openReader file 22 | grepit regex rdr 23 | `catch` fnf where 24 | fnf :: FileNotFoundException -> IO () 25 | fnf _ = stderr.println ("Could not read " ++ file) 26 | 27 | 28 | grepit :: Regex -> MutableIO BufferedReader -> IO () 29 | grepit pat rdr = forever line `catch` eof `finally` rdr.close 30 | where 31 | eof :: EOFException -> IO () 32 | eof _ = return () 33 | line = do 34 | line <- rdr.getLine 35 | when (line ~ pat) (println line) 36 | 37 | -------------------------------------------------------------------------------- /examples/HigherOrder.fr: -------------------------------------------------------------------------------- 1 | 2 | package examples.HigherOrder 3 | -- inline(numfunc) 4 | where 5 | 6 | -- import Data.List 7 | 8 | both :: (forall arg res.arg -> res) -> pb -> cu -> (au, ag) 9 | both f xs ys = (f xs, f ys) 10 | 11 | try1 = both (head []) 12 | try2 = both noterm 13 | 14 | -- the only way to write a function of type a -> b? 15 | noterm a = noterm a 16 | 17 | 18 | with :: (Num a, Num b) => (forall e.Num e => [e]->[e]) -> [a] -> [b] -> ([a], [b]) 19 | with f xs ys = (f xs, f ys) 20 | 21 | -- numfunc :: Num a => [a] -> [a] 22 | numfunc = map (fromInt 1+) 23 | 24 | -- wrong :: (Enum a, Num a) => ([a], [Integer]) 25 | wrong = with nu (nu [1..10]) ([100_000_000_000n..100_000_000_010n]) 26 | where 27 | nu :: Num n => [n] -> [n] 28 | nu = map (1+) 29 | 30 | higher :: Num b => (forall a.Num a => f a -> f a) -> f b -> f b 31 | higher f xs = f xs 32 | 33 | -- useh :: (Functor α, Num β) => α β -> α β 34 | useh = higher (fmap (+1)) 35 | 36 | main args 37 | | null args = print "no args: " 38 | >> println (issue50 [7,6 .. 1]) 39 | >> println (issue50a [7,6 .. 2]) 40 | | otherwise = print "some args: " >> println (useh [1], useh (Just 3.7)) 41 | 42 | -- issue 50 (solved): this did not typecheck 43 | issue50 :: Ord o => [o] -> o 44 | issue50 xs = (ST.run go) 45 | where go = return $ minimum xs 46 | 47 | --- without type signature it should compile as well, as it used to be 48 | issue50a xs = (ST.run go) 49 | where go = return $ minimum xs 50 | -------------------------------------------------------------------------------- /examples/JHashMap.java: -------------------------------------------------------------------------------- 1 | package examples; 2 | 3 | import java.io.BufferedReader; 4 | import java.io.IOException; 5 | import java.util.regex.Pattern; 6 | import java.util.regex.Matcher; 7 | import java.util.HashMap; 8 | 9 | import frege.runtime.Runtime; 10 | 11 | public final class JHashMap { 12 | 13 | public static void main(String[] args) { 14 | try { 15 | if ("count".equals(args[0])) 16 | count(); 17 | else if ("uniq".equals(args[0])) 18 | uniq(); 19 | } 20 | catch (IOException e) {} 21 | } 22 | 23 | 24 | 25 | public static void uniq() throws IOException { 26 | HashMap map = new HashMap<>(); 27 | 28 | String line = null; 29 | Pattern words = Pattern.compile("\\w+", 448); // same mode as in Frege, for fairness 30 | // int result = 0; 31 | BufferedReader in = Runtime.stdin.get(); 32 | 33 | while ((line = in.readLine()) != null) { 34 | // Matcher m = words.matcher(line); 35 | // while (m.find()) { 36 | // String key = m.group(); 37 | Integer n = map.get(line); 38 | if (n == null) map.put(line, 1); 39 | else map.put(line, n+1); 40 | // } 41 | } 42 | int wörter = 0; 43 | for (int n : map.values()) wörter += n; 44 | System.err.println(wörter); 45 | System.out.println(map.size()); 46 | 47 | } 48 | 49 | public static void count() throws IOException { 50 | String line = null; 51 | Pattern words = Pattern.compile("\\w+", 448); // same mode as in Frege, for fairness 52 | int result = 0; 53 | 54 | while ((line = Runtime.stdin.get().readLine()) != null) { 55 | Matcher m = words.matcher(line); 56 | while (m.find()) result++; 57 | } 58 | System.out.println(result); 59 | } 60 | 61 | } 62 | -------------------------------------------------------------------------------- /examples/MoreTailCall.fr: -------------------------------------------------------------------------------- 1 | -- module examples.MoreTailCall where 2 | 3 | import Data.List (isPrefixOf) 4 | 5 | match :: Int -> [Int] -> [Int] -> Bool 6 | match n list1 list2 = match1 (take n (cycle [1,1,2,2,2])) where 7 | 8 | match1 [] = True 9 | match1 list | list1 `isPrefixOf` list = match2 (drop (length list1) list) 10 | match1 _ = False 11 | 12 | match2 [] = False 13 | match2 list | list2 `isPrefixOf` list = match1 (drop (length list2) list) 14 | match2 _ = False 15 | 16 | --- should print true if argument is divisible by 5 17 | 18 | main = putStrLn $ show $ match 12345670 [1,1] [2,2,2] -------------------------------------------------------------------------------- /examples/Postfix.fr: -------------------------------------------------------------------------------- 1 | -- 2 | --- For Sean 3 | --- Show that postfix operators do indeed work. 4 | -- 5 | module examples.Postfix where 6 | 7 | import Test.QuickCheck as Q 8 | 9 | infix 1 `³` `²` 10 | 11 | --- cube of a number 12 | (x³) = x ^ 3 13 | 14 | --- square of a number 15 | (²) = (^2) 16 | 17 | prop23 = property (\(n :: Integer) -> (n³) == n*(n²)) 18 | 19 | main = do 20 | print "venti sette " 21 | println (3³) 22 | print "some cubes " 23 | println (map (³) [1..10]) 24 | Q.quickCheck prop23 25 | -------------------------------------------------------------------------------- /examples/RefExample.fr: -------------------------------------------------------------------------------- 1 | --- Example with references 2 | module examples.RefExample where 3 | 4 | import frege.Prelude hiding (STMutable, pure) 5 | 6 | type Var a b = Mutable a (Ref b) 7 | 8 | newVar :: v -> ST st (Var st v) 9 | newVar a = Ref.new a 10 | 11 | getVar :: (Var st v) -> ST st v 12 | getVar r = Ref.get r 13 | 14 | putVar :: (Var st v) -> v -> ST st () 15 | putVar r a = Ref.put r a 16 | 17 | --- increment the referenced value 18 | incVar ref = do 19 | int <- getVar ref 20 | putVar ref (int+1) 21 | 22 | workVar n = do 23 | ref <- newVar n -- create a Int reference 24 | incVar ref -- increment 3 times 25 | inc1 <- getVar ref -- remember value after first increment 26 | incVar ref 27 | incVar ref 28 | inc3 <- getVar ref -- get the final value 29 | ST.return (inc1, inc3) -- make ST s (Int, Int) 30 | 31 | foo = workVar 42 32 | bar = ST.run foo -- (workVar 42) 33 | pure n = ST.run (workVar n) 34 | standaloneVal = newVar 0 35 | 36 | main _ = println (ST.run foo) 37 | -- nogo1 :: Var µ Int 38 | -- nogo1 = ST.run standaloneVal 39 | 40 | -- nogo2 = ST.run (incVar (newVar 0)) 41 | -------------------------------------------------------------------------------- /examples/ReverseStdin.fr: -------------------------------------------------------------------------------- 1 | --- Reverse the standard input 2 | module examples.ReverseStdin where 3 | 4 | main _ = loop [] >>= mapM_ stdout.write 5 | 6 | loop :: [Int] -> IO [Int] 7 | loop acc = do 8 | i <- stdin.read 9 | if i < 0 then return acc -- end of file 10 | else loop (i:acc) 11 | -------------------------------------------------------------------------------- /examples/STM.fr: -------------------------------------------------------------------------------- 1 | module examples.STMExample where 2 | 3 | import Control.concurrent.STM 4 | import Control.Concurrent 5 | 6 | type Account = TVar Int 7 | 8 | newAccount :: Int -> IO Account 9 | newAccount amount = atomically $ TVar.new amount 10 | 11 | deposit :: Account -> Int -> STM () 12 | deposit account amount = do 13 | v <- account.read 14 | account.write (v + amount) 15 | 16 | withdraw :: Account -> Int -> STM () 17 | withdraw account amount = do 18 | v <- account.read 19 | account.write (v - amount) 20 | 21 | limitedWithdraw :: Account -> Int -> STM () 22 | limitedWithdraw account amount = do 23 | withdraw account amount 24 | bal <- account.read 25 | check (bal >= 0) 26 | 27 | transfer :: Account -> Account -> Int -> STM () 28 | transfer from to amount = do 29 | limitedWithdraw from amount 30 | deposit to amount 31 | 32 | main = do 33 | a1 <- newAccount 100 34 | a2 <- newAccount 50 35 | a3 <- newAccount 0 36 | 37 | (v1, v2, v3) <- atomically $ do 38 | v1 <- a1.read 39 | v2 <- a2.read 40 | v3 <- a3.read 41 | return (v1, v2, v3) 42 | 43 | println (v1, v2, v3) 44 | 45 | let t12 = transfer a1 a2 70 46 | t23 = transfer a2 a3 35 47 | t31 = transfer a3 a1 70 48 | 49 | forkIO $ mapM_ atomically $ replicate 100 $ t12 50 | forkIO $ mapM_ atomically $ replicate 300 $ t23 `orElse` t31 51 | 52 | Thread.sleep 5000 53 | 54 | (v1, v2, v3) <- atomically $ do 55 | v1 <- a1.read 56 | v2 <- a2.read 57 | v3 <- a3.read 58 | return (v1, v2, v3) 59 | 60 | println (v1, v2, v3) 61 | 62 | -------------------------------------------------------------------------------- /examples/SimpleIO.fr: -------------------------------------------------------------------------------- 1 | --- Demonstration of terminal input/output 2 | module examples.SimpleIO where 3 | 4 | import Test.QuickCheck 5 | 6 | --- The 'main' function will be called by the runtime when you run the 'SimpleIO' class. 7 | --- It will get passed the list of command line arguments, but we ignore them here. 8 | main _ = forever interaction 9 | `catch` eof 10 | `finally` println "See you again." 11 | where 12 | interaction = do 13 | reply <- prompt "Enter integer number: " 14 | case reply.integer of 15 | Left _ -> println ("`" ++ reply ++ "` is not an integer.") 16 | Right n -> println (show n ++ " is " 17 | ++ (if even n then "even" else "odd") 18 | ++ ".") 19 | prompt s = do 20 | stdout.print s 21 | stdout.flush 22 | getLine 23 | eof :: EOFException -> IO () 24 | eof _ = print "Good bye. " 25 | 26 | {-- 27 | The property 'p_test' checks the claim that 28 | every integral number must be either odd or even. 29 | -} 30 | p_test = property $ \(n::Integer) -> odd n ^^ even n -------------------------------------------------------------------------------- /examples/Sort.fr: -------------------------------------------------------------------------------- 1 | module examples.Sort where 2 | 3 | --- Mische 2 sortierte Listen 4 | merge ∷ (a→a→Ordering) → [a] → [a] → [a] -- optionale Typdeklaration 5 | merge comp xss yss = case xss of 6 | x:xs -> case yss of 7 | y:ys -> -- beide Listen sind nicht leer 8 | case comp x y of 9 | GT -> y : merge comp xss ys -- y kommt zuerst, da x "größer" ist 10 | _ -> x : merge comp xs yss -- andernfalls x 11 | [] -> xss -- wenn eine der Listen leer ist 12 | [] -> yss -- ist die andere Liste das Ergebnis 13 | 14 | --- Sortiere eine Liste _xs_ gemäß Vergleichsfunktion _comp_ 15 | 16 | sortBy ∷ (a→a→Ordering) → [a] → [a] -- optionale Typdeklaration 17 | sortBy comp [] = [] -- eine leere Liste ist schon sortiert 18 | sortBy comp [x] = [x] -- ebenso eine mit nur einem Element 19 | sortBy comp [x,y] = -- zwei Elemente können wir direkt sortieren 20 | case comp x y of 21 | GT -> [y,x] -- y kommt vor x 22 | _ -> [x,y] -- sonst ist es andersrum 23 | sortBy comp xs = -- sortieren und mischen der vorderen u. hinteren Hälfte 24 | merge comp (sortBy comp half1) (sortBy comp half2) 25 | where 26 | half1 = take n xs -- vordere Hälfte 27 | half2 = drop n xs -- hintere Hälfte 28 | n = length xs `div` 2 29 | 30 | --- Sortieren nach Ordnungsrelation des jeweiligen Typs 31 | sort ∷ Ord a ⇒ [a] → [a] 32 | sort = sortBy compare 33 | 34 | --- Eintrittspunkt 35 | --- Hierfür wird ein "public static void main(String[] args) { ... }" generiert 36 | main ∷ [String] → IO () 37 | main args = do 38 | println (sortBy (descending length) args) -- absteigend nach Länge 39 | println (sort args) -- alphabetisch 40 | where 41 | descending f a b = compare (f b) (f a) -- Argumente beim Vergleich vertauscht! 42 | -------------------------------------------------------------------------------- /examples/TailCalls.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | 3 | Demonstration of dealing with tail calls in Frege 4 | 5 | -} 6 | module examples.TailCalls 7 | inline(odd) 8 | where 9 | 10 | -- hide the standard functions even and odd which work with bitmasks 11 | import frege.Prelude hiding(even, odd) 12 | 13 | --- Check evenness by downcounting 14 | --- To be sure, we would normally do this by checking the rightmost bit in O(1) 15 | --- This code is solely for demonstration purposes 16 | even :: Int -> Bool 17 | even 0 = true 18 | even 1 = false 19 | even n = odd (pred n) 20 | 21 | odd :: Int -> Bool 22 | odd n = even (pred n) 23 | 24 | -- odd n = not (even (n-1)) 25 | 26 | main [arg] = println . even . atoi $ arg 27 | main _ = println (even 123456789) 28 | -------------------------------------------------------------------------------- /examples/UnicodeChars.fr: -------------------------------------------------------------------------------- 1 | --- translates its input to a slightly more verbose form 2 | 3 | -- A small joke from 𝕴𝖓𝖌𝖔 𝖂𝖊𝖈𝖍𝖘𝖚𝖓𝖌 4 | 5 | module examples.UnicodeChars where 6 | 7 | pure native chrname java.lang.Character.getName :: Int -> String 8 | 9 | --- print a table of interesting unicode characters 10 | main [] = do 11 | sequence_ 12 | . zipWith ($) (cycle [print, println]) 13 | . map nice 14 | . codepoints 15 | $ interesting 16 | println "" 17 | 18 | --- print a description of the arguments 19 | main args = sequence_ 20 | . zipWith ($) (cycle [print, println]) 21 | . map nice 22 | . codepoints 23 | . joined " " 24 | $ args 25 | 26 | --- ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ 27 | interesting = "∀∃√∛∜∞𝕬𝖆𝕭𝖇𝕮𝖈𝕯𝖉𝕰𝖊𝕱𝖋𝕲𝖌𝕳𝖍𝕴𝖎𝕵𝖏𝕶𝖐𝕷𝖑𝕸𝖒𝕹𝖓𝕺𝖔𝕻𝖕𝕼𝖖𝕽𝖗𝕾𝖘𝕿𝖙𝖀𝖚𝖁𝖛𝖂𝖜𝖃𝖝𝖄𝖞𝖅𝖟∷←↑→↓↔⇒░" 28 | 29 | codepoints s = cps 0 (CharSequence.fromString s) 30 | 31 | cps :: Int -> CharSequence -> [Int] 32 | cps !n !str 33 | | n >= str.length = [] 34 | | n+1 < str.length, c.isSurrogatePair (str.charAt (n+1)) 35 | = str.codePointAt n !: recurse 2 36 | | otherwise = ord c !: recurse 1 37 | where 38 | c = str.charAt n 39 | recurse k = cps (n+k) str 40 | 41 | nice i = String.format "%s U+%05x %-40.40s" s i (chrname i) :: String 42 | where 43 | s | Char.isSupplementaryCodePoint i 44 | = packed [Char.highSurrogate i, Char.lowSurrogate i] 45 | | otherwise = ctos (chr i) 46 | 47 | -------------------------------------------------------------------------------- /examples/Welcome.fr: -------------------------------------------------------------------------------- 1 | --- Test case for code generation with monadic code 2 | module examples.Welcome where 3 | 4 | main = do 5 | println "Hi there! What's your name?" 6 | name ← getLine 7 | println ("Welcome to Frege, " ++ name ++ "!") 8 | -------------------------------------------------------------------------------- /frege/StandardLibrary.fr: -------------------------------------------------------------------------------- 1 | --- The purpose of this package is to get all library modules compiled 2 | 3 | package StandardLibrary where 4 | 5 | -- import everything public, so we don't get "unused import" warnings 6 | 7 | import Control.Arrow public() 8 | import Control.CombineIn public() 9 | import Control.Concurrent public() 10 | import Control.DeepSeq public() 11 | import Control.First public() 12 | import Control.Second public() 13 | import Control.Tensor public() 14 | 15 | import Control.arrow.Kleisli public() 16 | 17 | import Control.monad.Reader public() 18 | import Control.monad.State public() 19 | 20 | import Control.monad.trans.EitherT public() 21 | import Control.monad.trans.MaybeT public() 22 | import Control.monad.trans.MonadIO public() 23 | import Control.monad.trans.MonadTrans public() 24 | 25 | import Control.concurrent.STM public() 26 | 27 | import Data.Bits public() 28 | import Data.Dec64 public() 29 | import Data.Char public() 30 | import Data.Compose public() 31 | import Data.Coproduct public() 32 | -- import Data.Dec64 public() 33 | import Data.Foldable public() 34 | import Data.Graph public() 35 | import Data.Iterators public() 36 | import Data.JSON public() 37 | import Data.List public() 38 | -- import Data.Map public() 39 | import Data.Maybe public() 40 | import Data.Either public() 41 | import Data.Monoid public() 42 | import Data.MicroParsec public() 43 | import Data.NonEmpty public() 44 | import Data.Product public() 45 | import Data.Stream public() 46 | import Data.Traversable public() 47 | import Data.Tree public() 48 | import Data.TreeMap public() 49 | import Data.HashMap public() 50 | import Data.Tuples public() 51 | import Data.Ix public() 52 | import Data.Array public() 53 | 54 | import Data.wrapper.Boolean public() 55 | import Data.wrapper.Const public() 56 | import Data.wrapper.Dual public() 57 | import Data.wrapper.Endo public() 58 | import Data.wrapper.Identity public() 59 | import Data.wrapper.Num public() 60 | import Data.wrapper.Ord public() 61 | import Data.wrapper.ZipList public() 62 | 63 | 64 | import Java.Awt public() 65 | import Java.IO public() 66 | import Java.Lang public() 67 | import Java.Net public() 68 | import Java.Swing public() 69 | import Java.Util public() 70 | 71 | import Java.lang.Reflect public() 72 | 73 | import Java.swing.GroupLayout public() 74 | 75 | import Java.util.Concurrent as JC public() 76 | import Java.util.Jar public() 77 | import Java.util.Zip public() 78 | 79 | import Lib.ForkJoin public() 80 | import Lib.Modules public() 81 | import Lib.PP public() 82 | 83 | import Test.QuickCheck public() 84 | 85 | import System.Random public() 86 | import System.Environment public() 87 | import System.Exit public() 88 | -------------------------------------------------------------------------------- /frege/StandardTools.fr: -------------------------------------------------------------------------------- 1 | --- The purpose of this package is to get all tools compiled 2 | 3 | module StandardTools where 4 | 5 | -- we use public imports to avoid "unused import" hints 6 | 7 | import frege.tools.Doc public() 8 | import frege.tools.YYgen public() 9 | import frege.tools.Quick public() 10 | import frege.ide.Utilities public() 11 | import frege.tools.Splitter public() 12 | import frege.tools.MakeDocIndex public() 13 | -------------------------------------------------------------------------------- /frege/Starter.fr: -------------------------------------------------------------------------------- 1 | --- dispatch between compiler and repl 2 | module frege.Starter where 3 | 4 | import Compiler.Main(main compiler) 5 | import Repl.FregeRepl(main repl) 6 | 7 | 8 | main :: [String] -> IO Bool 9 | main [] = repl >> pure true 10 | main ['^-?-?repl'] = repl >> pure true 11 | main other = compiler other 12 | 13 | -------------------------------------------------------------------------------- /frege/compiler/classes/QNameMatcher.fr: -------------------------------------------------------------------------------- 1 | --- Blur the difference between 'QName' and 'Sname' as far as display of items is concerned. 2 | module frege.compiler.classes.QNameMatcher where 3 | 4 | import Compiler.types.Tokens 5 | import Compiler.types.SNames 6 | import Compiler.types.Packs 7 | import Compiler.types.QNames 8 | import Compiler.types.Global as G 9 | 10 | 11 | --- helper type class to make 'unAlias' type-wise work on all 'TauT' 12 | protected class QNameMatcher n where 13 | private match :: Global -> n -> QName -> Bool 14 | private fakeQName :: n -> QName 15 | 16 | 17 | instance QNameMatcher SName where 18 | match _ _ _ = false 19 | fakeQName s = TName (Pack.new "fake.Pack") s.id.value 20 | 21 | 22 | instance QNameMatcher QName where 23 | match g q1 q2 = g.findit q1 == g.findit q2 24 | fakeQName q = q 25 | 26 | -------------------------------------------------------------------------------- /frege/compiler/common/Roman.fr: -------------------------------------------------------------------------------- 1 | --- Generate roman numerals 2 | module frege.compiler.common.Roman where 3 | 4 | import Data.Tuples public() 5 | 6 | private !alphabet = [ 7 | (1_000_000_000, 'T', 100_000_000, 'R'), 8 | ( 500_000_000, 'S', 100_000_000, 'R'), 9 | (100_000_000, 'R', 10_000_000, 'O'), 10 | ( 50_000_000, 'P', 10_000_000, 'O'), 11 | (10_000_000, 'O', 1_000_000, 'K'), 12 | ( 5_000_000, 'N', 1_000_000, 'K'), 13 | (1000000, 'K', 100000, 'H'), 14 | ( 500000, 'J', 100000, 'H'), 15 | (100000, 'H', 10000, 'F'), 16 | ( 50000, 'G', 10000, 'F'), 17 | (10000, 'F', 1000, 'M'), 18 | ( 5000, 'E', 1000, 'M'), 19 | (1000, 'M', 100, 'C'), 20 | ( 500, 'D', 100, 'C'), 21 | ( 100, 'C', 10, 'X'), 22 | ( 50, 'L', 10, 'X'), 23 | ( 10, 'X', 1, 'I'), 24 | ( 5, 'V', 1, 'I'), 25 | ( 1, 'I', 0, 'Z') 26 | ] 27 | 28 | !romNums = arrayCache (\n arr -> packed (romanNumber n)) 100 29 | romanUpper x 30 | | x >= 0, x < 100 = romNums `elemAt` x 31 | | otherwise = packed (romanNumber x) 32 | 33 | romanLower x = (romanUpper x).toLowerCase 34 | 35 | romanNumber n 36 | | n == minBound = '-' : 'T' : rom alphabet (abs (n + 1_000_000_000)) 37 | | n < 0 = '-' : rom alphabet (abs n) 38 | | n == 0 = ['Z'] 39 | | n == 1 = ['U' ] 40 | | n == 2 = ['B' ] 41 | | n == 3 = ['T' ] 42 | | n == 4 = ['Q' ] 43 | | otherwise = rom alphabet n 44 | where 45 | rom :: [(Int, Char, Int, Char)] -> Int -> [Char] 46 | rom (alpha@(u, uc, d, dc):xs) n 47 | | n >= u = uc : rom alpha (n-u) 48 | | n >= (u-d) = dc : uc : rom xs (n-u+d) 49 | | otherwise = rom xs n 50 | rom [] 0 = [] 51 | rom xx y = error ("rom " ++ show xx ++ " " ++ show y) 52 | 53 | -------------------------------------------------------------------------------- /frege/compiler/common/Tuples.fr: -------------------------------------------------------------------------------- 1 | --- This is an undocumented module. 2 | module frege.compiler.common.Tuples where 3 | -- generated by Splitter 4 | import frege.Prelude hiding(error, print, println, break, <+>) 5 | import frege.compiler.enums.TokenID(TokenID) 6 | import frege.compiler.types.Positions 7 | import frege.compiler.types.Tokens 8 | import frege.compiler.types.SNames 9 | import frege.compiler.types.Patterns 10 | import frege.compiler.types.Expression 11 | 12 | 13 | --- create a constructor for an n-tuple 14 | tuple n = let 15 | i = n-1 16 | commas = repeat "," 17 | string = "(" ++ fold (++) "" (take i commas) ++ ")" 18 | in string 19 | 20 | 21 | 22 | tupleName i t = With1 (baseTokenAt t) (baseTokenAt t).{tokid=CONID, value=tuple i} 23 | 24 | 25 | 26 | mkTuple con (pos::Position) [x] = x 27 | mkTuple con pos xs = fold app (con (pos.change CONID (tuple n)) (tupleName n pos.first) Nothing) xs 28 | where !n = length xs 29 | app a b = App a b Nothing 30 | 31 | 32 | 33 | 34 | mkpTuple (pos::Position) [p] = p 35 | mkpTuple pos xs = PCon (pos.change CONID (tuple n)) (tupleName n pos.first) xs 36 | where !n = length xs 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /frege/compiler/enums/CaseKind.fr: -------------------------------------------------------------------------------- 1 | --- "Kind" of a case 2 | module frege.compiler.enums.CaseKind where 3 | 4 | {-- 5 | case kind 6 | -} 7 | data CKind = 8 | CNormal --- normal case 9 | | CWhen --- case that falls through 10 | | CNoWarn --- compiler generated, do not emit warnings 11 | 12 | derive Eq CKind 13 | derive Enum CKind -------------------------------------------------------------------------------- /frege/compiler/enums/Literals.fr: -------------------------------------------------------------------------------- 1 | --- Classification of literals. 2 | module frege.compiler.enums.Literals where 3 | 4 | {-- 5 | type tag for Literals 6 | -} 7 | data Literalkind = 8 | LBool --- 'Bool', either true or false 9 | | LChar --- 'Char' 10 | | LString --- 'String' 11 | | LInt --- 'Int' literal, subject to limits 12 | | LBig --- 'Integer' literal, arbitrary length 13 | | LLong --- 'Long' literal, subject to limits 14 | | LFloat --- 'Float' literal 15 | | LDouble --- 'Double' literal 16 | | LDec --- 'Decimal' literal, subject to limits 17 | | LRegex --- 'Regex' literal 18 | 19 | --- tells us whether a literal of this kind can be negated 20 | isLiteralNumeric ∷ Literalkind → Bool 21 | isLiteralNumeric lk = lk >= LInt && lk <= LDec 22 | 23 | derive Enum Literalkind 24 | 25 | 26 | derive Show Literalkind 27 | -------------------------------------------------------------------------------- /frege/compiler/enums/RFlag.fr: -------------------------------------------------------------------------------- 1 | --- Hints for the code generator about run time behaviour of methods 2 | module frege.compiler.enums.RFlag where 3 | -- generated by Splitter 4 | import frege.data.Bits(BitSet) 5 | 6 | {-- 7 | Attributes that describe the run time behaviour of a function/value 8 | -} 9 | data RFlag = 10 | RValue {-- Returns a value in all cases. 11 | If this flag is absent, a lazy value will be returned. -} 12 | | RTailRec --- function is tail recursive 13 | | RSimple --- the defining expression is simple 14 | | RSafeTC --- function can be used as tail call safely 15 | | RMethod --- let bound functions only: implemented as method, not as lambda 16 | | RSelfRec --- self recursive (for CAF) 17 | 18 | derive Show RFlag 19 | 20 | 21 | derive Enum RFlag 22 | 23 | --- The 'RState' is maintained and persisted in class files for each variable and function 24 | type RState = BitSet RFlag 25 | 26 | 27 | -------------------------------------------------------------------------------- /frege/compiler/enums/SymState.fr: -------------------------------------------------------------------------------- 1 | --- Symbol state 2 | module frege.compiler.enums.SymState where 3 | 4 | {-- 5 | symbol state 6 | -} 7 | data SymState = Unchecked | Typechecking | Recursive | Typechecked | StrictChecked 8 | 9 | 10 | derive Eq SymState 11 | 12 | 13 | derive Ord SymState 14 | 15 | 16 | derive Show SymState 17 | 18 | 19 | derive Enum SymState 20 | 21 | 22 | -------------------------------------------------------------------------------- /frege/compiler/enums/TokenID.fr: -------------------------------------------------------------------------------- 1 | --- 'TokenID' and associated instances 2 | module frege.compiler.enums.TokenID where 3 | 4 | {-- 5 | The tokens for the frege language. 6 | -} 7 | 8 | data TokenID = 9 | CHAR 10 | | DOCUMENTATION | COMMENT 11 | | QUALIFIER | VARID | CONID 12 | | INTCONST | STRCONST | CHRCONST | BIGCONST 13 | | FLTCONST | LONGCONST | DBLCONST | DECCONST | REGEXP 14 | | DCOLON | ARROW | GETS | EARROW | DOTDOT 15 | | EXTENDS | SUPER -- generic kinds ≤ (extends) and ≥ (super) 16 | | PACKAGE | IMPORT | NATIVE 17 | | IF | THEN | ELSE | CLASS | WHERE 18 | | INSTANCE 19 | | DATA | CASE | OF | DERIVE 20 | | LET | IN | TYPE | TRUE | FALSE | PURE 21 | | PRIVATE | PUBLIC | PROTECTED | ABSTRACT | DO | FORALL 22 | | THROWS --- used to mark native methods that throw 23 | | MUTABLE --- used to mark always mutable native data 24 | | DEFAULT | NEWTYPE | FOREIGN -- Haskell 25 | | INFIX | INFIXL | INFIXR 26 | -- left, right and non associative operators with precedence order 1 to 16 27 | | LOP0 28 | | LOP1 | LOP2 | LOP3 | LOP4 29 | | LOP5 | LOP6 | LOP7 | LOP8 30 | | LOP9 | LOP10 | LOP11 | LOP12 31 | | LOP13 | LOP14 | LOP15 | LOP16 32 | | ROP0 33 | | ROP1 | ROP2 | ROP3 | ROP4 34 | | ROP5 | ROP6 | ROP7 | ROP8 35 | | ROP9 | ROP10 | ROP11 | ROP12 36 | | ROP13 | ROP14 | ROP15 | ROP16 37 | | NOP0 38 | | NOP1 | NOP2 | NOP3 | NOP4 39 | | NOP5 | NOP6 | NOP7 | NOP8 40 | | NOP9 | NOP10 | NOP11 | NOP12 41 | | NOP13 | NOP14 | NOP15 | NOP16 42 | | SOMEOP -- pseudo operator token 43 | | LEXERROR 44 | 45 | defaultInfix = LOP16 46 | 47 | derive Show TokenID 48 | 49 | 50 | derive Eq TokenID 51 | 52 | 53 | derive Ord TokenID 54 | 55 | 56 | derive Enum TokenID 57 | 58 | 59 | -------------------------------------------------------------------------------- /frege/compiler/enums/Visibility.fr: -------------------------------------------------------------------------------- 1 | --- cross module visibility of items 2 | module frege.compiler.enums.Visibility where 3 | 4 | --- cross module visibility of items 5 | data Visibility = 6 | Private --- item is not available in other packages, except constructors for inlined code 7 | | Protected --- item is available but will be imported only on demand 8 | | Public --- item is available and will be imported by default 9 | | Abstract --- makes type public but all constructors private 10 | 11 | instance Show Visibility where 12 | show Private = "private" 13 | show Public = "public" 14 | show Protected = "protected" 15 | show Abstract = "abstract" 16 | 17 | 18 | derive Eq Visibility 19 | 20 | 21 | derive Ord Visibility 22 | 23 | 24 | -------------------------------------------------------------------------------- /frege/compiler/grammar/Lexical.ebnf: -------------------------------------------------------------------------------- 1 | ARROW: '->' 2 | EARROW: '=>' 3 | GETS: '<-' 4 | DCOLON: '::' 5 | DOTDOT: '..' 6 | INSTANCE: 'instance' 7 | CLASS: 'class' 8 | DATA: 'data' 9 | TYPE: 'type' 10 | NEWTYPE: 'newtype' 11 | PURE: 'pure' 12 | MUTABLE: 'mutable' 13 | IMPORT: 'import' 14 | WHERE: 'where' 15 | THEN: 'then' 16 | ELSE: 'else' 17 | IF: 'if' 18 | CASE: 'case' 19 | OF: 'of' 20 | LET: 'let' 21 | IN: 'in' 22 | DO: 'do' 23 | NATIVE: 'native' 24 | PACKAGE: 'module' 25 | CASE: 'case' 26 | QUALIFIER: CONID '.' 27 | VARID: (LowercaseLetter | '_') (Letter | Digit | '_' | "'")* 28 | CONID: UppercaseLetter (Letter | Digit | '_' | "'")* 29 | Letter: '«any character in Unicode category: Letter»' 30 | LowercaseLetter: '«any character in Unicode categories Letter and not Uppercase»' 31 | UppercaseLetter: '«any character in Unicode categories Letter and Uppercase»' 32 | Digit: [0-9] 33 | STRCONST: '"' ([^"]|'\"') '"' 34 | -------------------------------------------------------------------------------- /frege/compiler/instances/NiceExprS.fr: -------------------------------------------------------------------------------- 1 | --- 'Nice' instance for 'ExprS' 2 | module frege.compiler.instances.NiceExprS where 3 | 4 | import Compiler.classes.Nice 5 | import Compiler.instances.Nicer 6 | import Compiler.types.Global 7 | import Compiler.types.SourceDefinitions 8 | 9 | instance Nice ExprS where 10 | nice :: ExprS -> Global -> String 11 | nice e g = case e of 12 | Vbl{name} -> name.show 13 | Lit{pos, kind, value} -> value 14 | Con{name} -> show name 15 | ConFS{name, fields} -> 16 | show name ++ "{" 17 | ++ joined ", " (map showfield fields) 18 | ++ "}" 19 | where 20 | showfield (label, ex) = label ++ "=" ++ nice ex g 21 | App{fun, arg} -> nice fun g ++ " " ++ nice arg g 22 | Let{defs, ex} -> "let ... in " ++ nice ex g 23 | Lam{pat, ex} -> "\\" ++ nice pat g ++ " -> " ++ nice ex g 24 | Ifte{cnd, thn, els} -> "if " ++ nice cnd g ++ " then " ++ nice thn g ++ " else " ++ nice els g 25 | Mem{ex, member} -> nice ex g ++ "." ++ member.value 26 | Case{ckind, ex, alts} -> "case " ++ nice ex g ++ " of {" ++ nicea alts ++ "}" 27 | where 28 | nice1a CAlt{pat, ex} = "{" ++ nice pat g ++ " -> " ++ nice ex g ++ "}" 29 | nicea [ca] = nice1a ca 30 | nicea (ca:_) = nice1a ca ++ ";..." 31 | nicea [] = "???" -- cannot happen 32 | Ann{ex, typ} -> nicer ex g ++ "::" ++ nicer typ g 33 | Term{ex} -> "(" ++ nicer ex g ++ ")" 34 | Infx{name, left, right} -> nicer left g ++ show name ++ nicer right g 35 | Enclosed{ex} → nice ex g 36 | 37 | 38 | -------------------------------------------------------------------------------- /frege/compiler/instances/PositionedSName.fr: -------------------------------------------------------------------------------- 1 | --- 'Positioned' instance for 'SNames' 2 | module frege.compiler.instances.PositionedSName where 3 | 4 | import Compiler.types.SNames 5 | import Compiler.types.Positions 6 | 7 | 8 | instance Positioned SName where 9 | is _ = "simple name" 10 | getpos Simple{id} = Pos id id 11 | getpos With1{ty, id} = Pos it id 12 | where !it = if ty.line < id.line then id else ty 13 | getpos With2{ns, ty, id} = Pos it id 14 | where !it = if ns.line < id.line 15 | then if ty.line < id.line 16 | then id 17 | else ty 18 | else ns 19 | getrange = getpos 20 | -------------------------------------------------------------------------------- /frege/compiler/passes/Final.fr: -------------------------------------------------------------------------------- 1 | --- The final compiler pass 2 | module frege.compiler.passes.Final where 3 | 4 | import Data.TreeMap as TM(TreeMap, insert, each) 5 | import Compiler.types.Global 6 | import Compiler.enums.Flags 7 | import Compiler.common.ImpExp 8 | import Compiler.types.Symbols 9 | import Compiler.types.External 10 | import Compiler.Classtools as CT 11 | 12 | 13 | buildMode :: Global -> Bool 14 | buildMode g = isOn g.options.flags MAKE && isOff g.options.flags IDEMODE 15 | 16 | clearTrees = changeST Global.{gen <- GenSt.{ 17 | tTree = empty, 18 | rTree = empty, 19 | sTree = empty, 20 | xTree = empty, 21 | expSym = empty, 22 | consts = empty 23 | }} 24 | 25 | {-- 26 | This pass does only anything in build mode. 27 | 28 | For exported symbols, it sets the 'Symbol.expr' so that it appears 29 | like just imported from a class file. 30 | 31 | Any other expressions are removed. 32 | 33 | *Note:* This pass should be the last one, since it destroys the symbol table. 34 | -} 35 | cleanSymtab = do 36 | g <- getST 37 | when (buildMode g) do 38 | changeST Global.{packages <- insert g.thisPack (maptab g)} 39 | clearTrees -- not needed anymore 40 | return ("symbol tables", 1) 41 | where 42 | maptab g = fmap symbol g.thisTab 43 | where 44 | symbol sym = case sym of 45 | SymV{name} | Just e <- g.gen.expSym.lookup name 46 | = sym.{expr = Just (exprFromA sarray eAarray eAarray.[e])} 47 | SymV{} = sym.{expr = Nothing} 48 | _ | sym.{env?} = sym.{env <- fmap symbol} 49 | | otherwise = sym 50 | swap :: (a,b) -> (b,a) 51 | swap (a,b) = (b,a) 52 | -- !kAarray = (arrayFromIndexList . map swap . each) empty -- g.gen.kTree 53 | !tAarray = (arrayFromIndexList . map swap . each) g.gen.tTree 54 | !rAarray = (arrayFromIndexList . map swap . each) g.gen.rTree 55 | !sAarray = (arrayFromIndexList . map swap . each) g.gen.sTree 56 | !eAarray = (arrayFromIndexList . map swap . each) g.gen.xTree 57 | karray = tAarray 58 | tarray = arrayCache rebuildTau tAarray.length 59 | rebuildTau n t = tauFromA karray tAarray.[n] t 60 | rarray = arrayCache rebuildRho rAarray.length 61 | rebuildRho n t = rhoFromA karray tarray sAarray rAarray.[n] t 62 | sarray = genericArrayMap (sigmaFromA karray tarray rarray) sAarray 63 | -------------------------------------------------------------------------------- /frege/compiler/types/ConstructorField.fr: -------------------------------------------------------------------------------- 1 | --- The type 'ConField' models a field in a data constructor. 2 | module frege.compiler.types.ConstructorField where 3 | -- generated by Splitter 4 | import frege.compiler.types.Positions 5 | import frege.compiler.enums.Visibility 6 | import frege.compiler.types.Types 7 | 8 | --- a constructor field 9 | data ConField s = !Field { pos :: Position, name, doc :: Maybe String, 10 | vis :: Visibility, strict :: Bool, typ :: SigmaT s } 11 | 12 | 13 | -------------------------------------------------------------------------------- /frege/compiler/types/ImportDetails.fr: -------------------------------------------------------------------------------- 1 | --- Detailed specification of items to import or hide. 2 | module frege.compiler.types.ImportDetails where 3 | 4 | 5 | import frege.compiler.types.SNames 6 | 7 | {-- 8 | structure of an import list 9 | --} 10 | data ImportList = Imports { 11 | publik, except :: Bool, -- kind of import list 12 | items :: [ImportItem] 13 | } 14 | 15 | 16 | {-- 17 | a single import item 18 | --} 19 | data ImportItem = Item { 20 | publik :: Bool, -- re-export this one 21 | name :: SName, -- to be resolved in the imported package 22 | members :: Maybe [ImportItem], -- members 23 | alias :: String -- guaranteed to be unqualified through syntax 24 | } where 25 | export :: ImportItem -> ImportItem 26 | export it = it.{publik = true, members <- fmap (map export)} 27 | 28 | 29 | --- Prototype for an 'Item' 30 | protoItem = Item { publik = false, name = protoSimple, members = Nothing, alias = "" } 31 | 32 | 33 | --- 'ImportList' used when none is specified 34 | linkAll = Imports { publik = false, except = true, items = [] } 35 | 36 | 37 | --- 'ImportList' for () 38 | linkNone = Imports { publik = false, except = false, items = [] } 39 | 40 | 41 | -------------------------------------------------------------------------------- /frege/compiler/types/JNames.fr: -------------------------------------------------------------------------------- 1 | --- Model of Java names. 2 | module frege.compiler.types.JNames where 3 | 4 | --- A Java name 5 | --- The 'JName.qual' part may have "." in it, or may be empty for unqualified names. 6 | --- The 'JName.base' part will be a simple 'String' for the last component. 7 | data JName = !JName {qual :: String, base :: String} 8 | 9 | instance Show JName where 10 | show (JName "" x) = x 11 | show (JName p x) = p ++ "." ++ x 12 | 13 | instance Eq JName where 14 | ja == jb = show ja == show jb 15 | hashCode ja = hashCode ja.show 16 | 17 | 18 | 19 | 20 | {-- 21 | Given a 'JName' and a member name, returns the 'JName' of the member. 22 | -} 23 | memberOf (JName "" b) c = JName b c 24 | memberOf (JName a b) c = JName (a++"."++b) c 25 | 26 | 27 | -------------------------------------------------------------------------------- /frege/compiler/types/NSNames.fr: -------------------------------------------------------------------------------- 1 | --- Names of name spaces. 2 | module frege.compiler.types.NSNames where 3 | 4 | 5 | --- A namespace name, not to be confused with an ordinary 'String' 6 | newtype NSName = NSX { unNS :: String } 7 | 8 | 9 | derive Eq NSName 10 | 11 | 12 | derive Ord NSName 13 | 14 | 15 | derive Show NSName 16 | 17 | 18 | -------------------------------------------------------------------------------- /frege/compiler/types/QNames.fr: -------------------------------------------------------------------------------- 1 | --- An internal qualified name. 2 | module frege.compiler.types.QNames where 3 | 4 | import frege.compiler.types.Packs 5 | 6 | --- qualified name 7 | data QName = 8 | TName { !pack :: Pack, !base :: String } 9 | | VName { !pack :: Pack, !base :: String } 10 | | MName { !tynm :: QName, !base :: String } 11 | | Local { !uid :: Int, !base :: String } 12 | where 13 | getpack (TName p _) = p 14 | getpack (VName p _) = p 15 | getpack (MName (TName p _) _) = p 16 | getpack (MName _ _) = Prelude.error "illegal MName" 17 | getpack (Local{}) = Pack.new "" 18 | 19 | --- tell if a 'QName' is from a certain package 20 | frompack q p = getpack q == p 21 | 22 | 23 | key (TName _ s) = "T+" ++ s 24 | key vmName = vmName.base 25 | 26 | --- tell if this names a tuple constructor or type 27 | istuple s = QName.base s ~ ´^\(,+\)$´ 28 | --- change the base name 29 | qual (TName p _) = TName p 30 | qual (VName p _) = VName p 31 | qual (MName t _) = MName t 32 | qual (Local {uid}) = Local uid 33 | --- tell if this is the name of a let or lambda bound item 34 | isLocal (Local{}) = true 35 | isLocal _ = false 36 | 37 | 38 | derive Eq QName 39 | 40 | 41 | derive Ord QName 42 | 43 | 44 | derive Show QName 45 | 46 | 47 | {-- (isTName x) ist das Wahre gdw. x unter den Begriff Typname fällt -} 48 | isTName (TName _ _) = true 49 | isTName _ = false 50 | 51 | 52 | -------------------------------------------------------------------------------- /frege/compiler/types/SNames.fr: -------------------------------------------------------------------------------- 1 | --- Unresolved names in source code form. 2 | module frege.compiler.types.SNames where 3 | 4 | 5 | import frege.compiler.types.Tokens 6 | import frege.compiler.enums.TokenID(CONID,VARID,LOP1,NOP16) 7 | 8 | --- an unresolved, maybe qualified identifier 9 | data SName = ! Simple { id :: Token } {-- 10 | Construct a simple name. 11 | syntactically forced to be 'VARID', 'CONID' or 'LOP1'..'NOP16' 12 | -} 13 | | ! With1 { ty :: Token, id :: Token } {-- 14 | Construct a qualified name. 15 | -} 16 | | ! With2 { ns, ty :: Token, id :: Token } {-- 17 | Construct a fully qualified name. 18 | -} 19 | 20 | 21 | instance Show SName where 22 | show (Simple t) = t.value 23 | show (With1 {ty, id}) = ty.value ++ "." ++ id.value 24 | show (With2 {ns, ty, id}) = ns.value ++ "." ++ ty.value ++ "." ++ id.value 25 | 26 | --- > "foo" `qBy` Conid 27 | --- supplements a partial name with a "member" 28 | qBy :: Token -> SName -> SName 29 | qBy t (Simple con) {- con.tokid == CONID -} = With1 con t 30 | qBy t (With1 ty id){- id.tokid == CONID -} = With2 ty id t 31 | qBy t name = error ("Can't qualify " ++ t.value ++ " by " ++ show name) 32 | 33 | --- > withNS "PreludeBase" (Simple "foo") 34 | --- qualifies a given name with the given name space 35 | withNS :: String -> SName -> SName 36 | withNS s (Simple t) = With1 t.{tokid=CONID, value=s} t 37 | withNS s (With1 c t) = With2 c.{tokid=CONID, value=s} c t 38 | withNS s name = error ("Can't set namespace " ++ s ++ " for " ++ show name) 39 | 40 | 41 | 42 | 43 | listSourceToList = With2 listToken listToken.{value="ListSource"} listToken.{tokid=VARID, value="toList"} 44 | 45 | 46 | protoSimple = Simple underlineToken 47 | 48 | --- produce PreludeBase.name for some token 49 | wellKnown :: Token -> String -> SName 50 | wellKnown t s = With1 (baseTokenAt t) t.{tokid=VARID, value=s} 51 | 52 | --- make token appear as if it was qualified by "PreludeBase" 53 | fromBase t = With1 (baseTokenAt t) t 54 | 55 | baseFlip t = wellKnown t "flip" 56 | 57 | 58 | --- simple name that must be known in this context 59 | contextName :: Token -> String -> SName 60 | contextName t s = Simple t.{tokid=VARID, value=s} 61 | 62 | 63 | 64 | 65 | derive Eq SName 66 | 67 | 68 | instance Ord SName where 69 | Simple t1 <=> Simple t2 = t1.value. <=> t2.value 70 | (s1@With1{}) <=> (s2@With1{}) = (s1.ty.value, s1.id.value). <=> (s2.ty.value, s2.id.value) 71 | (s1@With2{}) <=> (s2@With2{}) = (s1.ns.value, s1.ty.value, s1.id.value). <=> 72 | (s2.ns.value, s2.ty.value, s2.id.value) 73 | s1 <=> s2 = (constructor s1). <=> (constructor s2) 74 | 75 | 76 | -------------------------------------------------------------------------------- /frege/compiler/types/Strictness.fr: -------------------------------------------------------------------------------- 1 | --- Strictness information for function arguments 2 | module frege.compiler.types.Strictness where 3 | 4 | --- Strictness information for function arguments 5 | --- This is stored in 'SymD' and 'SymV' symbols. 6 | data Strictness = U --- lazy argument 7 | | S [Strictness] {-- strict argument, for product types 8 | there may be additional information for the 9 | subcomponents 10 | -} 11 | where 12 | isStrict U = false 13 | isStrict _ = true 14 | 15 | 16 | instance Eq Strictness where 17 | U == U = true 18 | S x == S y = (length x). == (length y) && and (zipWith (Strictness.==) x y) 19 | _ == _ = false 20 | hashCode U = 1 21 | hashCode (S x) = x.hashCode 22 | 23 | 24 | allLazy = repeat U 25 | 26 | 27 | allStrict = repeat (S []) 28 | 29 | 30 | instance Show Strictness where 31 | show U = "u" 32 | show (S []) = "s" 33 | show (S xs) = "s(" ++ joined "" (map show xs) ++ ")" 34 | 35 | 36 | {-- 37 | * [usage] @decodeS string@ 38 | * [returns] the decoded strictness value 39 | * [requires] the string must have been constructed with 'Strictness.show' 40 | * [ensures] @forAll Strictness.arbitrary { s | s == decodeS (show s) }@ 41 | -} 42 | decodeS :: String -> Strictness 43 | decodeS s = fst (decode s) where 44 | decode (s @ ´^u´) = (U, strtail s 1) 45 | decode (s @ ´^s´) = (S list, rest) where (list,rest) = decodeList (strtail s 1) 46 | decode s = Prelude.error ("decodeS: bad string " ++ s.show) 47 | decodeList (s @ ´^\(´) = listElems (strtail s 1) 48 | decodeList s = ([], s) 49 | listElems (s @ ´^\)´) = ([], strtail s 1) 50 | listElems s = (e:elems,rest) where 51 | (e,rs) = decode s 52 | (elems,rest) = listElems rs 53 | 54 | 55 | -------------------------------------------------------------------------------- /frege/compiler/types/Targets.fr: -------------------------------------------------------------------------------- 1 | --- Model the compilation target, conversion between "1.8" and 'Target' 2 | module frege.compiler.types.Targets where 3 | 4 | --- Compilation target 5 | data Target = Target {!major, !minor :: Int } where 6 | --- decode a target specification 7 | --- Old form: 1.5, 1.6, 1.7, 1.8 8 | --- New form: 9, ... 9 | decode ∷ String → Maybe Target 10 | decode (m~´^(1)\.([5678])$´) = do 11 | maj ← m.group 1 12 | min ← m.group 2 13 | pure (Target maj.atoi min.atoi) 14 | decode (m~´^(\d+)$´) = do 15 | maj ← m.group 1 16 | pure (Target maj.atoi (-1)) 17 | decode _ = Nothing 18 | 19 | instance Show Target where 20 | show t 21 | | t.minor >= 0 = "%d.%d".format t.major t.minor 22 | | otherwise = "%d".format t.major 23 | 24 | derive Eq Target 25 | derive Ord Target 26 | 27 | --- The 'Target' corresponding to our running VM 28 | --- This is based on the system property *java.specification.version* 29 | thisTarget = fromMaybe bad do 30 | jsv ← System.getProperty "java.specification.version" 31 | Target.decode jsv 32 | where 33 | bad = error ("strange java.specification.version: " 34 | ++ show (System.getProperty "java.specification.version")) 35 | 36 | java7 = Target{major=1, minor=7} -------------------------------------------------------------------------------- /frege/control/Arrow.fr: -------------------------------------------------------------------------------- 1 | --- type class for 'Arrow's 2 | package frege.control.Arrow where 3 | 4 | import frege.Prelude 5 | 6 | import frege.control.Category (Category()) 7 | import frege.control.First 8 | import frege.control.Second 9 | import frege.control.CombineIn 10 | 11 | {-- 12 | Basic arrow definitions, based on 13 | Generalising Monads to Arrows, by John Hughes, 14 | Science of Computer Programming, pp67-111, May 2000. 15 | -} 16 | class (Category a, First a, Second a, CombineIn a) => Arrow a where 17 | --- Lift a function to an arrow. 18 | arr :: (b -> c) -> a b c 19 | 20 | instance Arrow (->) where 21 | arr = id 22 | -------------------------------------------------------------------------------- /frege/control/Category.fr: -------------------------------------------------------------------------------- 1 | --- Introduction of the type class for 'http://en.wikipedia.org/wiki/Category_(mathematics) categories'. 2 | protected package frege.control.Category 3 | inline (F.id) 4 | where 5 | 6 | import frege.prelude.PreludeBase 7 | import frege.control.Semigroupoid 8 | 9 | --- The following type alias serves only to name the 'F.id' in the inline clause. 10 | private type F = (->) 11 | 12 | {-- 13 | A category is a 'Semigroupoid' with the following additional properties: 14 | 15 | - For every object @A@, there exists a mophism @id(A): A -> A@ called the 16 | _identity morphism for A_, such that for every morphism @f: A -> B@ we have 17 | > id(B) • f = f = f • id(A) 18 | -} 19 | class (Semigroupoid f) => Category f where 20 | --- the identity morphism 21 | id :: f a a 22 | 23 | {-- 24 | The category of Frege functions 25 | -} 26 | instance Category (->) where 27 | --- Identity on values 28 | --- @id x@ is @x@ 29 | id = \x -> x -------------------------------------------------------------------------------- /frege/control/CombineIn.fr: -------------------------------------------------------------------------------- 1 | --- type class 'CombineIn', which provides the '&&&' operator 2 | package frege.control.CombineIn where 3 | 4 | import frege.control.Semigroupoid (Semigroupoid()) 5 | 6 | infixr 3 `&&&` 7 | 8 | class (Semigroupoid f) => CombineIn f where 9 | {-- 10 | Send the input to both argument semigroupoids and combine 11 | their output. 12 | -} 13 | (&&&) :: f a b -> f a c -> f a (b, c) 14 | 15 | instance CombineIn (->) where 16 | f &&& g = \a -> (f a, g a) -------------------------------------------------------------------------------- /frege/control/First.fr: -------------------------------------------------------------------------------- 1 | --- type class 'First' with 'first' operation 2 | package frege.control.First where 3 | 4 | import frege.control.Tensor 5 | 6 | class (Tensor f) => First f where 7 | {-- 8 | Send the first component of the input through the argument 9 | tensor, and copy the rest unchanged to the output. 10 | -} 11 | first :: f a b -> f (a, c) (b, c) 12 | 13 | instance First (->) where 14 | first f = \(a, c) -> (f a, c) -------------------------------------------------------------------------------- /frege/control/Second.fr: -------------------------------------------------------------------------------- 1 | --- type class 'Second' with 'second' operation 2 | package frege.control.Second where 3 | 4 | import frege.control.Tensor 5 | 6 | class (Tensor f) => Second f where 7 | {-- 8 | Send the second component of the input through the argument 9 | tensor, and copy the rest unchanged to the output. 10 | -} 11 | second :: f c d -> f (a, c) (a, d) 12 | 13 | instance Second (->) where 14 | second f = \(a, c) -> (a, f c) -------------------------------------------------------------------------------- /frege/control/Semigroupoid.fr: -------------------------------------------------------------------------------- 1 | --- Introduction of the 'http://en.wikipedia.org/wiki/Semigroupoid semigroupoid'. 2 | 3 | protected package frege.control.Semigroupoid 4 | inline (F.•) 5 | where 6 | 7 | import frege.prelude.PreludeBase 8 | 9 | --- serves only to name 'F.•' in the inline clause 10 | private type F = (->) 11 | 12 | infixr 16 `•` -- f . g . h = f . (g . h) 13 | 14 | {-- 15 | Formally, a semigroupoid consists of 16 | - a set of things called objects. 17 | - for every two objects A and B a set Mor(A,B) of things called morphisms from A to B. 18 | If @f@ is in Mor(A,B), we write @f : A → B@. 19 | - for every three objects A, B and C a binary operation 20 | @Mor(A,B) × Mor(B,C) → Mor(A,C)@ called *composition* of morphisms. 21 | The composition of @f : A → B@ and @g : B → C@ is written as @g • f@. 22 | 23 | such that the following axiom holds: 24 | 25 | [associativity] if @f : A → B@, @g : B → C@ and @h : C → D@ then @h • (g • f) = (h • g) • f@. 26 | --} 27 | class Semigroupoid f where 28 | --- morphism composition 29 | (.) :: f b c -> f a b -> f a c 30 | 31 | 32 | infixr 1 `>>>` 33 | infixr 1 `<<<` 34 | 35 | --- Right-to-left composition. This is the same a ordinary composition with '•'. 36 | (<<<) :: Semigroupoid f => f b c -> f a b -> f a c 37 | (<<<) = (.) 38 | 39 | --- Left-to-right composition 40 | (>>>) :: Semigroupoid f => f a b -> f b c -> f a c 41 | f >>> g = g . f 42 | 43 | --- The semigroupoid of Frege values where morphisms are functions. 44 | instance Semigroupoid (->) where 45 | --- function composition 46 | f . g = \a -> f (g a) 47 | -------------------------------------------------------------------------------- /frege/control/Tensor.fr: -------------------------------------------------------------------------------- 1 | --- The 'Tensor' type class with '***' operation. 2 | package frege.control.Tensor where 3 | 4 | import frege.control.Semigroupoid (Semigroupoid()) 5 | 6 | infixr 3 `***` 7 | 8 | class (Semigroupoid f) => Tensor f where 9 | {-- 10 | Split the input between the two argument semigroupoids and combine 11 | their output. Note that this is in general not a functor. 12 | -} 13 | (***) :: f a b -> f c d -> f (a, c) (b, d) 14 | 15 | instance Tensor (->) where 16 | f *** g = \(a, c) -> (f a, g c) -------------------------------------------------------------------------------- /frege/control/arrow/Kleisli.fr: -------------------------------------------------------------------------------- 1 | --- Kleisli operators, 'Arrow' and 'Monad' instances 2 | package frege.control.arrow.Kleisli where 3 | 4 | import frege.Prelude hiding (id, .) -- will not be necessary 5 | import frege.control.Semigroupoid 6 | -- import frege.control.Category 7 | import frege.control.Arrow 8 | 9 | data Kleisli m a b = Kleisli { run :: a -> m b } 10 | 11 | instance Monad m => Arrow (Kleisli m) where 12 | id = Kleisli return 13 | 14 | Kleisli f . Kleisli g = Kleisli (f <=< g) 15 | 16 | arr f = Kleisli (return . f) 17 | 18 | first (Kleisli k) = Kleisli (\(b, d) -> fmap (\c -> (c, d)) (k b)) 19 | 20 | second (Kleisli k) = Kleisli (\(a, c) -> fmap (\d -> (a, d)) (k c)) 21 | 22 | Kleisli f *** Kleisli g = Kleisli go 23 | where 24 | go (a, c) = (,) <$> f a <*> g c 25 | 26 | Kleisli f &&& Kleisli g = Kleisli go 27 | where 28 | go a = (,) <$> f a <*> g a 29 | 30 | instance Monad m => Monad (Kleisli m a) where 31 | pure b = Kleisli (\_ -> return b) 32 | 33 | fmap f (Kleisli k) = Kleisli (fmap f . k) 34 | 35 | Kleisli kf <*> Kleisli kb = Kleisli go 36 | where 37 | go a = do 38 | f <- kf a 39 | b <- kb a 40 | return (f b) 41 | 42 | Kleisli k >>= f = Kleisli go 43 | where 44 | go a = do 45 | b <- k a 46 | (f b).run a 47 | -------------------------------------------------------------------------------- /frege/control/monad/Reader.fr: -------------------------------------------------------------------------------- 1 | --- 'Reader' monad and monad transformer, based on 'Kleisli' 2 | package frege.control.monad.Reader where 3 | 4 | import frege.Prelude hiding (Reader) 5 | import frege.control.arrow.Kleisli 6 | import frege.data.wrapper.Identity 7 | 8 | type Reader a b = Kleisli Identity a b 9 | 10 | type ReaderT m a b = Kleisli m a b 11 | 12 | ask :: Monad m => ReaderT m e e 13 | ask = id -------------------------------------------------------------------------------- /frege/control/monad/trans/EitherT.fr: -------------------------------------------------------------------------------- 1 | --- 'Monad' transformer for 'Either' 2 | package frege.control.monad.trans.EitherT where 3 | 4 | 5 | import Data.Monoid 6 | import frege.control.monad.trans.MonadTrans 7 | import frege.control.monad.trans.MonadIO 8 | 9 | data EitherT l m a = EitherT { run :: m (Either l a) } 10 | 11 | 12 | left :: Monad m => l -> EitherT l m a 13 | left = EitherT . return . Left 14 | 15 | instance Functor f => Functor (EitherT l f) where 16 | fmap :: Functor γ => (δ -> α) -> EitherT β γ δ -> EitherT β γ α 17 | fmap f = EitherT . fmap (fmap f) . EitherT.run 18 | 19 | instance Monad m => Monad (EitherT l m) where 20 | pure = EitherT . pure . Right 21 | EitherT x >>= f = EitherT do 22 | res <- x 23 | case res of 24 | Right r -> EitherT.run (f r) 25 | Left l -> return (Left l) 26 | 27 | instance MonadTrans (EitherT l) where 28 | lift = EitherT . liftM Right 29 | 30 | instance MonadIO m => MonadIO (EitherT l m) where 31 | liftIO = lift . liftIO 32 | 33 | instance (MonadPlus m) => MonadPlus (EitherT l m) where 34 | mzero = EitherT mzero 35 | e1 `mplus` e2 = EitherT $ e1.run `mplus` e2.run 36 | 37 | instance (MonadAlt m) => MonadAlt (EitherT l m) where 38 | pzero = EitherT pzero 39 | e1 <|> e2 = EitherT $ e1.run <|> e2.run 40 | e1 <+> e2 = EitherT $ e1.run <+> e2.run 41 | 42 | instance (Monad m, Monoid a) => Monoid (EitherT l m a) where 43 | mempty = pure mempty 44 | mappend = liftA2 mappend 45 | -------------------------------------------------------------------------------- /frege/control/monad/trans/MaybeT.fr: -------------------------------------------------------------------------------- 1 | --- 'Monad' transformer for 'Maybe' 2 | package frege.control.monad.trans.MaybeT where 3 | 4 | import frege.control.monad.trans.MonadTrans 5 | import frege.control.monad.trans.MonadIO 6 | 7 | {-- 8 | The parameterizable maybe monad, obtained by composing an arbitrary 9 | monad with the 'Maybe' monad. 10 | 11 | Computations are actions that may produce a value or fail. 12 | 13 | The 'return' function yields a successful computation, while (>>=) 14 | sequences two subcomputations, failing on the first error. 15 | -} 16 | data MaybeT m a = MaybeT { run :: m (Maybe a) } 17 | 18 | --- Transform the computation inside a @MaybeT@. 19 | mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b 20 | mapMaybeT f mt = MaybeT $ f $ MaybeT.run mt 21 | 22 | instance Functor m => Functor (MaybeT m) where 23 | fmap f = mapMaybeT (fmap (fmap f)) 24 | 25 | instance Monad m => Alt (MaybeT m) where 26 | (<|>) = mplus 27 | 28 | instance Monad m => Monad (MaybeT m) where 29 | pure mt = lift $ pure mt 30 | x >>= f = MaybeT do 31 | v <- MaybeT.run x 32 | case v of 33 | Nothing -> return Nothing 34 | Just y -> MaybeT.run (f y) 35 | 36 | instance Monad m => MonadFail (MaybeT m) where 37 | fail _ = MaybeT (return Nothing) 38 | 39 | instance Monad m => MonadPlus (MaybeT m) where 40 | mzero = MaybeT (return Nothing) 41 | mplus x y = MaybeT $ do 42 | v <- MaybeT.run x 43 | case v of 44 | Nothing -> MaybeT.run y 45 | Just _ -> return v 46 | 47 | instance MonadTrans MaybeT where 48 | lift mt = MaybeT (liftM Just mt) 49 | 50 | instance MonadIO m => MonadIO (MaybeT m) where 51 | liftIO io = lift (liftIO io) -------------------------------------------------------------------------------- /frege/control/monad/trans/MonadIO.fr: -------------------------------------------------------------------------------- 1 | --- Monads in which 'IO' computations may be embedded. 2 | package frege.control.monad.trans.MonadIO 3 | inline (IO.liftIO) 4 | where 5 | 6 | {-- 7 | Monads in which 'IO' computations may be embedded. 8 | 9 | Any monad built by applying a sequence of monad transformers to the 10 | 'IO' monad will be an instance of this class. 11 | 12 | Instances should satisfy the following laws, which state that 'liftIO' 13 | is a transformer of monads: 14 | 15 | > liftIO . return = return 16 | 17 | > liftIO (m >>= f) = liftIO m >>= (liftIO . f) 18 | 19 | -} 20 | 21 | class Monad m => MonadIO m where 22 | --- Lift a computation from the 'IO' monad. 23 | liftIO :: IO a -> m a 24 | 25 | instance MonadIO IO where 26 | liftIO = id 27 | -------------------------------------------------------------------------------- /frege/control/monad/trans/MonadTrans.fr: -------------------------------------------------------------------------------- 1 | --- provide utility function 'lift' for 'Monad' transformers 2 | package frege.control.monad.trans.MonadTrans where 3 | 4 | class MonadTrans t where 5 | --- Lift a computation from the argument monad to the constructed monad. 6 | lift :: Monad m => m a -> t m a 7 | -------------------------------------------------------------------------------- /frege/data/Compose.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | Composition of two applicative functors _f_ and _g_ 3 | such that the type _f (g a)_ can itself be treated 4 | as applicative functor. 5 | -} 6 | package Data.Compose where 7 | 8 | data Compose f g a = Compose { run :: f (g a) } 9 | 10 | compose :: f (g a) -> Compose f g a 11 | compose = Compose 12 | 13 | instance (Functor f, Functor g) => Functor (Compose f g) where 14 | fmap f (Compose fga) = Compose (fmap (fmap f) fga) 15 | 16 | instance (Applicative f, Applicative g) => Applicative (Compose f g) where 17 | pure a = Compose (pure (pure a)) 18 | Compose fgf <*> Compose fga = Compose ((<*>) <$> fgf <*> fga) -------------------------------------------------------------------------------- /frege/data/Coproduct.fr: -------------------------------------------------------------------------------- 1 | --- co-product 2 | package frege.data.Coproduct where 3 | 4 | data Coproduct (f ∷ * → *) (g ∷ * → *) a = Inl (f a) | Inr (g a) 5 | 6 | instance (Functor f, Functor g) => Functor (Coproduct f g) where 7 | fmap f (Inl fa) = Inl (fmap f fa) 8 | fmap f (Inr ga) = Inr (fmap f ga) 9 | -------------------------------------------------------------------------------- /frege/data/Either.fr: -------------------------------------------------------------------------------- 1 | module Data.Either where 2 | 3 | fromLeft :: a -> Either a b -> a 4 | fromLeft _ (Left a) = a 5 | fromLeft a _ = a 6 | 7 | fromRight :: b -> Either a b -> b 8 | fromRight _ (Right b) = b 9 | fromRight b _ = b 10 | -------------------------------------------------------------------------------- /frege/data/Maybe.fr: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright © 2011 - 2021, Ingo Wechsung 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or 7 | without modification, are permitted provided that the following 8 | conditions are met: 9 | 10 | - Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | - Redistributions in binary form must reproduce the above 14 | copyright notice, this list of conditions and the following 15 | disclaimer in the documentation and/or other materials provided 16 | with the distribution. Neither the name of the copyright holder 17 | nor the names of its contributors may be used to endorse or 18 | promote products derived from this software without specific 19 | prior written permission. 20 | 21 | *THIS SOFTWARE IS PROVIDED BY THE 22 | COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 23 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 24 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 25 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER 26 | OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 27 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 28 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 29 | USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED 30 | AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 31 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 32 | IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF 33 | THE POSSIBILITY OF SUCH DAMAGE.* 34 | -} 35 | 36 | {-- 37 | This package simply re-exports what is required by Haskell 2010 38 | -} 39 | 40 | package Data.Maybe where 41 | 42 | import frege.Prelude public( 43 | Maybe(Nothing, Just), 44 | maybe, isJust, isNothing, unJust fromJust, 45 | fromMaybe, listToMaybe, maybeToList, catMaybes, mapMaybe 46 | ) 47 | -------------------------------------------------------------------------------- /frege/data/Product.fr: -------------------------------------------------------------------------------- 1 | --- A pair of two applicative functors, both applied to the same type 2 | package frege.data.Product where 3 | 4 | import frege.Prelude hiding(product) 5 | 6 | data Product f g a = Prod (f a) (g a) 7 | 8 | instance (Functor f, Functor g) => Functor (Product f g) where 9 | fmap f (Prod fa ga) = Prod (fmap f fa) (fmap f ga) 10 | 11 | --- view a tuple as 'Product' 12 | product = uncurry Prod 13 | 14 | --- make a tuple from a 'Product' 15 | unproduct (Prod a b) = (a,b) -------------------------------------------------------------------------------- /frege/data/wrapper/Boolean.fr: -------------------------------------------------------------------------------- 1 | --- Provide wrappers 'Any' and 'All' for 'Bool' 'Monoid's 2 | module frege.data.wrapper.Boolean where 3 | 4 | import Data.Monoid 5 | 6 | {-- 7 | 'Monoid' for 'Bool' with operation 'oder' and identity @false@ 8 | -} 9 | newtype Any = Any { unwrap :: Bool } --- wrap a 'Bool' value 10 | derive Show Any 11 | derive Eq Any 12 | derive Ord Any 13 | 14 | --- Haskell compatibility: get the value wrapped by Any 15 | getAny = Any.unwrap 16 | 17 | --- The 'Semigroup' instance for 'Any' uses operation 'oder'. 18 | instance Semigroup Any where 19 | --- Disjunction 20 | Any x `mappend` Any y = Any (x `oder` y) 21 | 22 | --- The 'Monoid' for 'Any' uses @false@ as identity. 23 | instance Monoid Any where 24 | --- 'Any' @false@ 25 | mempty = Any false 26 | 27 | 28 | {-- 29 | 'Monoid' for 'Bool' with operation 'und' and identity @true@ 30 | -} 31 | newtype All = All { unwrap :: Bool } --- wrap a 'Bool' value 32 | derive Show All 33 | derive Eq All 34 | derive Ord All 35 | 36 | --- Haskell compatibility: get the value wrapped by All 37 | getAll = All.unwrap 38 | 39 | 40 | --- The 'Semigroup' instance for 'All' uses operation 'und'. 41 | instance Semigroup All where 42 | --- Conjunction 43 | All x `mappend` All y = All (x `und` y) 44 | 45 | --- The 'Monoid' for 'All' uses @true@ as identity. 46 | instance Monoid All where 47 | --- 'All' @true@ 48 | mempty = All true 49 | 50 | -------------------------------------------------------------------------------- /frege/data/wrapper/Const.fr: -------------------------------------------------------------------------------- 1 | --- type level 'const' 2 | --- 'Const' is a way to use some arbitrary type as an applicative 'Functor' 3 | package frege.data.wrapper.Const where 4 | 5 | import Data.Monoid 6 | 7 | data Const a b = Const { get :: a } 8 | 9 | instance Functor (Const m) where 10 | fmap _ (Const v) = Const v 11 | 12 | instance Monoid m => Applicative (Const m) where 13 | pure _ = Const mempty 14 | Const f <*> Const v = Const (f `mappend` v) -------------------------------------------------------------------------------- /frege/data/wrapper/Dual.fr: -------------------------------------------------------------------------------- 1 | --- Provides a wrapper for a 'Monoid' that works in reverse 2 | module Data.wrapper.Dual where 3 | 4 | import Data.Monoid 5 | 6 | --- Provides a 'Monoid' where 'mappend' appears flipped. 7 | newtype Dual a = Dual { unwrap :: a } --- wrap a value to give a 'Dual' 8 | derive Show (Dual a) 9 | derive Eq (Dual a) 10 | derive Ord (Dual a) 11 | 12 | --- get the value wrapped by 'Dual' (Haskell compatibility) 13 | getDual = Dual.unwrap 14 | 15 | instance Semigroup a => Semigroup (Dual a) where 16 | --- > Dual "foo" <> Dual "bar" == Dual "barfoo" 17 | Dual x `mappend` Dual y = Dual (mappend y x) 18 | 19 | instance Monoid a => Monoid (Dual a) where 20 | --- @Dual e@ where @e@ is the identity of the wrapped value. 21 | mempty = Dual mempty 22 | 23 | -------------------------------------------------------------------------------- /frege/data/wrapper/Endo.fr: -------------------------------------------------------------------------------- 1 | --- 'Monoid' instance for endofunctions 2 | module frege.data.wrapper.Endo where 3 | 4 | import Data.Monoid 5 | 6 | 7 | --- The monoid of endomorphisms under composition. 8 | newtype Endo a = Endo { unwrap :: a -> a } 9 | appEndo = Endo.unwrap 10 | 11 | {-- 12 | The 'Monoid' instance for 'Endo' has functions as objects, 13 | uses '•' as operation and the identity is 'id'. -} 14 | instance Monoid (Endo a) where 15 | --- > Endo f <> Endo g = Endo (f . g) 16 | Endo f `mappend` Endo g = Endo (f • g) 17 | --- > Endo id 18 | mempty = Endo id 19 | -------------------------------------------------------------------------------- /frege/data/wrapper/Identity.fr: -------------------------------------------------------------------------------- 1 | 2 | {-- 3 | 'Identity', along with instances for 'Functor', 4 | 'Applicative', 'Bind', 'Apply', 'Monad', 5 | 'Semigroup', 'Monoid' and 'ListSource' 6 | -} 7 | 8 | package frege.data.wrapper.Identity 9 | inline (Identity.run, Identity.Identity.pure, 10 | Identity.Identity.>>, Identity.Identity.>>=, 11 | Identity.Identity.fmap) 12 | where 13 | 14 | import Data.Monoid 15 | 16 | {-- 17 | 18 | The identity functor and monad. 19 | 20 | This trivial type constructor serves two purposes: 21 | 22 | - It can be used with functions parameterized by a 23 | 'Functor' or 'Monad'. 24 | 25 | - It can be used as a base monad to which a series of monad 26 | transformers may be applied to construct a composite monad. 27 | Most monad transformer modules include the special case of 28 | applying the transformer to 'Identity'. For example, @State s@ 29 | is an abbreviation for @StateT s 'Identity'@. 30 | -} 31 | 32 | 33 | --- Identity functor and monad. 34 | data Identity a = Identity { run :: a } 35 | 36 | derive Eq (Identity a) 37 | derive Ord (Identity a) 38 | instance (Enum a) => Enum (Identity a) where 39 | succ = fmap succ 40 | from = Identity . from 41 | ord = ord . Identity.run 42 | pred = fmap pred 43 | enumFromThenTo (Identity a) (Identity b) (Identity c) = map Identity $ enumFromThenTo a b c 44 | enumFromThen (Identity a) (Identity b) = map Identity $ enumFromThen a b 45 | instance (Show a) => Show (Identity a) where 46 | display = display . Identity.run 47 | showChars = showChars . Identity.run 48 | show = show . Identity.run 49 | 50 | instance Monad Identity where 51 | (Identity m) >>= k = k m 52 | (Identity m) >> (Identity n) = Identity n 53 | pure = Identity 54 | Identity f <*> Identity x = Identity (f x) 55 | fmap f (Identity m) = Identity (f m) 56 | 57 | 58 | instance Semigroup a => Semigroup (Identity a) where 59 | Identity x `mappend` Identity y = Identity (x `mappend` y) 60 | 61 | instance Monoid a => Monoid (Identity a) where 62 | mempty = Identity mempty 63 | 64 | instance ListSource Identity where 65 | toList (Identity x) = [x] 66 | -------------------------------------------------------------------------------- /frege/data/wrapper/Num.fr: -------------------------------------------------------------------------------- 1 | --- 'Monoid' wrappers for numeric data 2 | module frege.data.wrapper.Num where 3 | 4 | import Data.Monoid 5 | 6 | {-- 7 | 'Monoid' wrapper for numbers with operation '*' and identity 1 8 | -} 9 | newtype Product a = Product { unwrap :: a } --- wrap a number 10 | derive Show (Product a) 11 | derive Eq (Product a) 12 | derive Ord (Product a) 13 | 14 | --- Haskell compatibility: get the value wrapped by 'Product' 15 | getProduct = Product.unwrap 16 | 17 | 18 | --- The 'Semigroup' instance for 'Product' uses operation '*' 19 | instance Num a => Semigroup (Product a) where 20 | --- > Product 3 <> Product 7 == Product 21@ 21 | Product x `mappend` Product y = Product (x * y) 22 | 23 | --- The 'Monoid' instance for 'Product' has identity @1@ 24 | instance Num a => Monoid (Product a) where 25 | --- > Product 1@ 26 | mempty = Product one 27 | 28 | 29 | {-- 30 | 'Monoid' wrapper for numbers with operation '+' and identity 0 31 | -} 32 | newtype Sum a = Sum { unwrap :: a } --- wrap a number 33 | derive Show (Sum a) 34 | derive Eq (Sum a) 35 | derive Ord (Sum a) 36 | 37 | --- Haskell compatibility: get the value wrapped by 'Sum' 38 | getSum = Sum.unwrap 39 | 40 | 41 | --- The 'Semigroup' instance for 'Sum' uses operation '+' 42 | instance Num a => Semigroup (Sum a) where 43 | --- > Sum 19 <> Sum 23 == Sum 42 44 | Sum x `mappend` Sum y = Sum (x + y) 45 | 46 | --- The 'Monoid' instance for 'Sum' has identity @0@ 47 | instance Num a => Monoid (Sum a) where 48 | --- > Sum 0 49 | mempty = Sum zero 50 | 51 | 52 | -------------------------------------------------------------------------------- /frege/data/wrapper/Ord.fr: -------------------------------------------------------------------------------- 1 | --- 'Monoid' instances for bounded and ordered values, using 'min' and 'max' 2 | module frege.data.wrapper.Ord where 3 | 4 | import Data.Monoid 5 | 6 | 7 | newtype Min a = Min { unwrap :: a } 8 | derive Show (Min a) 9 | derive Eq (Min a) 10 | derive Ord (Min a) 11 | 12 | getMin = Min.unwrap 13 | 14 | instance (Ord a, Bounded a) => Monoid (Min a) where 15 | mempty = Min maxBound 16 | instance Ord a => Semigroup (Min a) where 17 | Min a `mappend` Min b = Min (a `min` b) 18 | 19 | 20 | newtype Max a = Max { unwrap :: a } 21 | derive Show (Max a) 22 | derive Eq (Max a) 23 | derive Ord (Max a) 24 | 25 | getMax = Max.unwrap 26 | 27 | instance (Ord a, Bounded a) => Monoid (Max a) where 28 | mempty = Max minBound 29 | instance Ord a => Semigroup (Max a) where 30 | Max a `mappend` Max b = Max (a `max` b) 31 | -------------------------------------------------------------------------------- /frege/data/wrapper/ZipList.fr: -------------------------------------------------------------------------------- 1 | --- A zip list. 2 | package frege.data.wrapper.ZipList where 3 | 4 | import Data.Monoid 5 | import Data.Foldable as F () 6 | import Data.Traversable as T () 7 | 8 | newtype ZipList a = ZipList { get :: [a] } where 9 | empty = ZipList [] 10 | null (ZipList []) = true 11 | null (ZipList _) = false 12 | 13 | instance Functor ZipList where 14 | fmap f (ZipList xs) = ZipList (map f xs) 15 | 16 | instance Applicative ZipList where 17 | pure x = ZipList (repeat x) 18 | ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs) 19 | 20 | instance ListSource ZipList where 21 | toList (ZipList xs) = xs 22 | 23 | -- instance ListEmpty ZipList 24 | 25 | instance ListMonoid ZipList where 26 | ZipList xs ++ ZipList ys = ZipList (xs ++ ys) 27 | 28 | instance ListView ZipList where 29 | uncons (ZipList []) = Nothing 30 | uncons (ZipList (x:xs)) = Just (x, ZipList xs) 31 | 32 | length (ZipList xs) = length xs 33 | take n (ZipList xs) = ZipList (take n xs) 34 | 35 | instance Semigroup (ZipList a) where 36 | mappend xs ys = xs ++ ys 37 | 38 | instance Monoid (ZipList a) where 39 | mempty = ZipList [] 40 | 41 | instance F.Foldable ZipList where 42 | foldr f x (ZipList xs) = Prelude.foldr f x xs 43 | foldl f x (ZipList xs) = Prelude.fold f x xs 44 | 45 | instance T.Traversable ZipList where 46 | traverse f (ZipList xs) = fmap ZipList $ T.traverse f xs -------------------------------------------------------------------------------- /frege/java/lang/Reflect.fr: -------------------------------------------------------------------------------- 1 | {- «•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•» 2 | 3 | Copyright © 2011 - 2021, Ingo Wechsung 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or 7 | without modification, are permitted provided that the following 8 | conditions are met: 9 | 10 | Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | Redistributions in binary form must reproduce the above 14 | copyright notice, this list of conditions and the following 15 | disclaimer in the documentation and/or other materials provided 16 | with the distribution. Neither the name of the copyright holder 17 | nor the names of its contributors may be used to endorse or 18 | promote products derived from this software without specific 19 | prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE 22 | COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 23 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 24 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 25 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER 26 | OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 27 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 28 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 29 | USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED 30 | AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 31 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 32 | IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF 33 | THE POSSIBILITY OF SUCH DAMAGE. 34 | 35 | «•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•» -} 36 | 37 | --- Java types from package java.lang.reflect 38 | module frege.java.lang.Reflect where 39 | 40 | data InvocationTargetException = pure native java.lang.reflect.InvocationTargetException 41 | derive Exceptional InvocationTargetException 42 | 43 | --- This type class is used only to add methods to 'Class' 44 | protected class ReflectedClass c where 45 | protected native getDeclaredField :: c -> String -> IO Field 46 | throws NoSuchFieldException 47 | 48 | instance ReflectedClass (Class a) 49 | 50 | data Field = pure native java.lang.reflect.Field where 51 | native get :: Field -> Maybe Object -> IO Object 52 | throws IllegalAccessException, IllegalArgumentException, 53 | ExceptionInInitializerError 54 | 55 | -------------------------------------------------------------------------------- /frege/java/swing/GroupLayout.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | Inner classes of javax.swing.GroupLayout 3 | --} 4 | package frege.java.swing.GroupLayout where 5 | 6 | data Alignment = pure native javax.swing.GroupLayout.Alignment where 7 | pure native leading javax.swing.GroupLayout.Alignment.LEADING :: Alignment 8 | pure native trailing javax.swing.GroupLayout.Alignment.TRAILING :: Alignment 9 | pure native center javax.swing.GroupLayout.Alignment.CENTER :: Alignment 10 | pure native baseline javax.swing.GroupLayout.Alignment.BASELINE :: Alignment 11 | 12 | 13 | data ParallelGroup = native javax.swing.GroupLayout.ParallelGroup 14 | 15 | 16 | data Group = native javax.swing.GroupLayout.Group 17 | -------------------------------------------------------------------------------- /frege/java/util/Zip.fr: -------------------------------------------------------------------------------- 1 | --- Java classes from package @java.util.zip@ 2 | 3 | module frege.java.util.Zip where 4 | 5 | import Java.Util(Enumeration) 6 | 7 | data ZipException = pure native java.util.zip.ZipException 8 | derive Exceptional ZipException 9 | 10 | 11 | data ZipFile = native java.util.zip.ZipFile where 12 | native new :: File -> IOMutable ZipFile throws ZipException, IOException 13 | native entries' entries :: MutableIO ZipFile -> IOMutable (Enumeration (extends (MutableIO ZipEntry))) 14 | entries ∷ MutableIO ZipFile → IOMutable (Enumeration (MutableIO ZipEntry)) 15 | entries zip = zip.entries' 16 | native getInputStream :: MutableIO ZipFile -> MutableIO ZipEntry -> IOMutable InputStream throws IOException 17 | --- get the 'ZipEntry' for the specified name, or 'Nothing' if not found. 18 | native getEntry :: MutableIO ZipFile -> String -> IO (Maybe (MutableIO ZipEntry)) 19 | 20 | data ZipEntry = native java.util.zip.ZipEntry where 21 | native new :: MutableIO ZipEntry -> IOMutable ZipEntry 22 | | String -> IOMutable ZipEntry 23 | native getName :: MutableIO ZipEntry -> IO String 24 | native isDirectory :: MutableIO ZipEntry -> IO Bool 25 | 26 | -------------------------------------------------------------------------------- /frege/run7/Lazy.java: -------------------------------------------------------------------------------- 1 | package frege.run7; 2 | 3 | import java.util.concurrent.Callable; 4 | 5 | /** 6 | * Common interface of all lazy values. 7 | * 8 | * @author ingo 9 | * 10 | */ 11 | // @FunctionalInterface 12 | public interface Lazy extends Callable { 13 | 14 | /** 15 | *

Compute the value if it is needed.

16 | * 17 | * @see java.util.concurrent.Callable#call() 18 | */ 19 | public R call(); 20 | 21 | /** 22 | *

Tell if this is really a {@link Thunk}

23 | * @return 24 | */ 25 | public Thunk asThunk(); 26 | 27 | /** 28 | *

Tell if this is shared.

29 | *

Data and functions whose {@link Lazy#call()} method returns this as well 30 | * as simple boxes that just hold a value ready to be supplied and {@link Thunk}s 31 | * are considered shared. 32 | *

But a bare lambda expression is assumed to be in need of sharing. For example:

33 | * () -> 42 34 | */ 35 | public boolean isShared(); 36 | /** 37 | */ 38 | public static abstract class D implements Lazy { 39 | @Override public Thunk asThunk() { return null; } 40 | @Override public boolean isShared() { return false; } 41 | } 42 | } -------------------------------------------------------------------------------- /frege/run8/Lazy.java: -------------------------------------------------------------------------------- 1 | package frege.run8; 2 | 3 | import java.util.concurrent.Callable; 4 | 5 | 6 | /** 7 | * Common interface of all lazy values. 8 | * 9 | * @author ingo 10 | * 11 | */ 12 | // @FunctionalInterface 13 | public interface Lazy extends Callable { 14 | 15 | /** 16 | *

Compute the value if it is needed.

17 | * 18 | * @see java.util.concurrent.Callable#call() 19 | */ 20 | public abstract R call(); 21 | 22 | /** 23 | *

Tell if this is really a {@link Thunk}

24 | * @return 25 | */ 26 | public default Thunk asThunk() { return null; } 27 | 28 | /** 29 | *

Tell if this is shared.

30 | *

Data and functions whose {@link Lazy#call()} method returns this as well 31 | * as simple boxes that just hold a value ready to be supplied and {@link Thunk}s 32 | * are considered shared. 33 | *

But a bare lambda expression is assumed to be in need of sharing. For example:

34 | * () -> 42 35 | * @return false, if sharing this would make any sense, otherwise true 36 | */ 37 | public default boolean isShared() { return false; } 38 | 39 | } 40 | -------------------------------------------------------------------------------- /frege/run8/Utils.java: -------------------------------------------------------------------------------- 1 | package frege.run8; 2 | 3 | import java.util.function.*; 4 | /** 5 | * Helper functions to convert between Java8 function types and Frege functions. 6 | * @author ingo 7 | * 8 | */ 9 | public abstract class Utils { 10 | /**

Make a {@link BiFunction} from a Frege function that takes 2 arguments

*/ 11 | public static BiFunction bifunction(Func.U> f) { 12 | return (T a, U b) -> f 13 | .apply(Thunk.lazy(a)) 14 | .call() 15 | .apply(Thunk.lazy(b)) 16 | .call(); 17 | } 18 | 19 | } -------------------------------------------------------------------------------- /frege/runtime/BlackHole.java: -------------------------------------------------------------------------------- 1 | /** 2 | */ 3 | package frege.runtime; 4 | 5 | /** 6 | *

Provides a uniq object that is useless and cannot be casted 7 | * to any other type, except {@link Object}.

8 | * 9 | *

This is used in the runtime to detect so called black holes. 10 | * Black holes are expressions that demand evaluation of themselves 11 | * while they are evaluated.

12 | * 13 | *

Consider:

14 | * 15 | *

let a = a + 1 in a + 42

16 | * 17 | *

Note that the following is not a blackhole:

18 | * 19 | *

let a = 1:a in take 20 a

20 | * 21 | *

because evaluation of 1:a does not demand 22 | * evaluation of a.

23 | * 24 | * @author ingo 25 | * 26 | */ 27 | final public class BlackHole { 28 | private BlackHole() {} 29 | /** 30 | *

A uniq object that is useless and cannot be casted 31 | * to any other type, except {@link Object}.

32 | */ 33 | final public static BlackHole it = new BlackHole(); 34 | } 35 | -------------------------------------------------------------------------------- /frege/runtime/CompilerSupport.java: -------------------------------------------------------------------------------- 1 | package frege.runtime; 2 | 3 | 4 | import frege.runtime.Meta; 5 | 6 | import java.io.IOException; 7 | import java.io.UnsupportedEncodingException; 8 | import java.nio.file.Files; 9 | 10 | 11 | public class CompilerSupport { 12 | 13 | public static Meta.FregePackage getFrege(ClassLoader loader, String pack) 14 | throws ClassNotFoundException { 15 | Class cl = null; 16 | cl = loader.loadClass(pack); 17 | return cl.getAnnotation(Meta.FregePackage.class); 18 | } 19 | 20 | public static Meta.FunctionPointers getFunctions(ClassLoader loader, String pack) 21 | throws ClassNotFoundException { 22 | Class cl = null; 23 | cl = loader.loadClass(pack); 24 | return cl.getAnnotation(Meta.FunctionPointers.class); 25 | } 26 | 27 | /** 28 | * Reads the named (text) file in the given encoding. 29 | * 30 | * @return a String representing the contents of the file 31 | * @throws UnsupportedEncodingException, IOException 32 | */ 33 | static public String slurp(String filename, String encoding) 34 | throws UnsupportedEncodingException, IOException { 35 | return new String( 36 | Files.readAllBytes( 37 | java.nio.file.FileSystems.getDefault().getPath(filename)), 38 | encoding); 39 | } 40 | 41 | } 42 | -------------------------------------------------------------------------------- /frege/runtime/GuardFailed.java: -------------------------------------------------------------------------------- 1 | package frege.runtime; 2 | 3 | /** 4 | *

Exception thrown when the guard of the last case alternative fails.

5 | *

throw new GuardFailed(...) is inserted by the compiler 6 | * at appropriate places and helps identify the 7 | * source line number of the guard.

8 | * @author ingo 9 | * 10 | */ 11 | public class GuardFailed extends Undefined { 12 | 13 | static final long serialVersionUID = 1L; 14 | 15 | public GuardFailed(String qname, int line) { 16 | super(qname + " at line " + line + ": guard failed."); 17 | } 18 | 19 | } 20 | -------------------------------------------------------------------------------- /frege/runtime/NoMatch.java: -------------------------------------------------------------------------------- 1 | package frege.runtime; 2 | 3 | 4 | 5 | /** 6 | *

Exception thrown when all matches of a case or lambda fail.

7 | *

8 | * throw new NoMatch(...) is 9 | * inserted by the compiler at appropriate places. 10 | *

11 | */ 12 | 13 | 14 | public class NoMatch extends Undefined { 15 | static final long serialVersionUID = 1L; 16 | 17 | public NoMatch(String qname, int line, Object x) { 18 | super(qname + " at line " + line + " no match for value " + x); 19 | } 20 | } 21 | 22 | -------------------------------------------------------------------------------- /frege/runtime/Phantom.java: -------------------------------------------------------------------------------- 1 | package frege.runtime; 2 | 3 | /** 4 | *

Container for ST phantom types.

5 | * 6 | *

When BBB is a subtype of AAA, then a ST BBB action can be embedded in a ST AAA action 7 | * but not the other way around.

8 | * 9 | *

(This is experimental)

10 | * 11 | * @author ingo 12 | * 13 | */ 14 | public class Phantom { 15 | 16 | /** the root of the phantom hierarchy, this is used for IO actions */ 17 | public interface RealWorld {} 18 | /** Graphic with JavaFX */ 19 | public interface JavaFX extends RealWorld {} 20 | /** Software transactional memory */ 21 | public interface STM extends RealWorld {} 22 | /** Subtypes to play with */ 23 | public interface XorY extends RealWorld {} 24 | public interface XorZ extends RealWorld {} 25 | public interface XXX extends XorY, XorZ {} 26 | public interface YYY extends XorY {} 27 | public interface ZZZ extends XorZ {} 28 | /** 29 | * this should not be exposed, but ... 30 | */ 31 | public final static RealWorld theRealWorld = new RealWorld () {}; 32 | } 33 | -------------------------------------------------------------------------------- /frege/runtime/Ref.java: -------------------------------------------------------------------------------- 1 | /* «•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•» 2 | 3 | Copyright © 2011 - 2021, Ingo Wechsung 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or 7 | without modification, are permitted provided that the following 8 | conditions are met: 9 | 10 | Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | Redistributions in binary form must reproduce the above 14 | copyright notice, this list of conditions and the following 15 | disclaimer in the documentation and/or other materials provided 16 | with the distribution. Neither the name of the copyright holder 17 | nor the names of its contributors may be used to endorse or 18 | promote products derived from this software without specific 19 | prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE 22 | COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 23 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 24 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 25 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER 26 | OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 27 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 28 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 29 | USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED 30 | AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 31 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 32 | IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF 33 | THE POSSIBILITY OF SUCH DAMAGE. 34 | 35 | «•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•»«•» */ 36 | 37 | package frege.runtime; 38 | 39 | 40 | /** 41 | *

Mutable references.

42 | * 43 | *

Used to realize type Prelude.IORef a s.

44 | * 45 | */ 46 | /** 47 | *

Boxed references.

48 | *

This is not a pure type.

49 | */ 50 | public final class Ref { 51 | /** 52 | *

Mutable reference to a frege object.

53 | * 54 | *

This is used for the IORef type in the Prelude.

55 | */ 56 | private A j; 57 | /** Construct a reference. Because this is a native function, the type is correct. */ 58 | public Ref(A a) { j = a; } 59 | /** getter */ 60 | public A get() { return j; } 61 | /** setter */ 62 | public void put(A a) { j = a; } 63 | } 64 | -------------------------------------------------------------------------------- /frege/runtime/Regex9.java: -------------------------------------------------------------------------------- 1 | /** 2 | * 3 | */ 4 | package frege.runtime; 5 | 6 | import java.util.regex.Matcher; 7 | import java.util.regex.MatchResult; 8 | import java.util.regex.Pattern; 9 | 10 | /** 11 | *

Helper functions for PreludeBase and PreludeRegex

12 | * 13 | *

The methods here help us to hide the {@link java.util.regex.Matcher} type, 14 | * which is impure, and cannot made pure, because copying is effectively impossible 15 | * at least from JDK9 on.

16 | *

Instead, all Frege code will work with {@link java.util.regex.MatchResult}, which is 17 | * a pure interface, and since JDK9 apparently backed by an immutable class.

18 | * @author ingo 19 | * 20 | */ 21 | public class Regex9 { 22 | 23 | /***

implements the (=~) operator

*/ 24 | public static MatchResult findResult(String s, Pattern p) { 25 | Matcher m = p.matcher(s); 26 | if (m.find()) return m; 27 | else return null; 28 | } 29 | 30 | /***

implements the findAt function with offset

*/ 31 | public static MatchResult findResult(String s, Pattern p, int n) { 32 | Matcher m = p.matcher(s); 33 | if (n >= 0 && n < s.length() && m.find(n)) return m; 34 | else return null; 35 | } 36 | 37 | /***

implements the (~) operator

*/ 38 | public static boolean find(String s, Pattern p) { 39 | return p.matcher(s).find(); 40 | } 41 | 42 | /***

implements replaceFirst

*/ 43 | public static String replaceFirst(String s, Pattern p, String r) { 44 | return p.matcher(s).replaceFirst(r); 45 | } 46 | 47 | /***

implements replaceAll

*/ 48 | public static String replaceAll(String s, Pattern p, String r) { 49 | return p.matcher(s).replaceAll(r); 50 | } 51 | } 52 | -------------------------------------------------------------------------------- /frege/runtime/Undefined.java: -------------------------------------------------------------------------------- 1 | 2 | package frege.runtime; 3 | 4 | /** 5 | *

Exception thrown when the undefined value is evaluated.

6 | * @author ingo 7 | * 8 | */ 9 | public class Undefined extends IllegalArgumentException { 10 | private int two = 2; // used to fool the compiler, see die() below 11 | static final long serialVersionUID = 1L; 12 | /** 13 | * Construct an undefined value from a string, e.g. 14 | * 
15 | 	 * 
16 | 	 * Prelude.error "you blew it"
17 | 	 * 
18 | 	 *
19 | * @param err description of the error 20 | */ 21 | public Undefined(String err) { 22 | super(err); 23 | } 24 | 25 | /** 26 | * Construct an undefined value from a string and another exception. 27 | * 28 | *

This is used by Frege code to throw any exception catched from 29 | * invocation of native functions.
30 | * This mechanism avoids throws clauses on frege functions.

31 | * @param err 32 | * @param cause 33 | */ 34 | public Undefined(String err, Throwable cause) { 35 | super(err, cause); 36 | } 37 | 38 | /** 39 | * Method used by Frege code to throw exceptions. 40 | * 41 | *

An exception from some native method, wrapped in {@link Undefined} 42 | * can be thrown everywhere without throws clauses or try ... catch ... 43 | * blocks. 44 | * 45 | *

This function actually never returns, but we need some return type to make 46 | * the Frege type checker happy and also to give the code generator a reason 47 | * to actually invoke this method.

48 | **/ 49 | public final boolean die() { 50 | if (two+two == 4) throw this; 51 | // never reached (except when someone resets 'two' by means of reflection) 52 | return false; 53 | } 54 | } 55 | -------------------------------------------------------------------------------- /frege/runtime/Value.java: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright © 2011 - 2021, Ingo Wechsung 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or 6 | without modification, are permitted provided that the following 7 | conditions are met: 8 | 9 | Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. Neither the name of the copyright holder 16 | nor the names of its contributors may be used to endorse or 17 | promote products derived from this software without specific 18 | prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE 21 | COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 22 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 23 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 24 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER 25 | OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 28 | USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED 29 | AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 31 | IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF 32 | THE POSSIBILITY OF SUCH DAMAGE. 33 | 34 | */ 35 | 36 | package frege.runtime; 37 | 38 | /** 39 | * All non-native Frege values, including {@link Lambda}s, implement {@link Value}. 40 | * 41 | * @author ingo 42 | * 43 | */ 44 | public interface Value { 45 | /** 46 | * @return the zero based constructor number for algebraic data types, and 0 for functions. 47 | */ 48 | public int constructor(); 49 | } 50 | -------------------------------------------------------------------------------- /frege/system/Environment.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | This package provides compatible definitions for Haskell 2010's 3 | System.Environment but mostly they do not translate to a Java 4 | environment. 5 | 6 | getEnv can be made to work once it is wired into how main is 7 | executed (it's currently a stub and will be updated after Ingo 8 | has completed a rewrite of main / runMain). 9 | 10 | getProgName really has no equivalent in the Java world since 11 | it is based on the UNIX idea of an executable name or the 12 | symbolic link to an executable. For now it arbitrarily returns 13 | an empty string (returning "java" or "java.exe" would be just 14 | as (in)accurate). 15 | 16 | getEnv is specified to fail with System.IO.Error.isDoesNotExistError 17 | if no such environment variable exists, but Frege uses Java 18 | exceptions so instead we throw an IllegalArgumentException. 19 | Using the underlying (Java) System.getenv is recommended 20 | since that returns Maybe String instead 21 | --} 22 | module frege.system.Environment where 23 | 24 | import frege.java.Lang 25 | 26 | private native argv frege.run.RunTM.argv :: JArray String 27 | 28 | getArgs :: IO [String] 29 | getArgs = pure (toList argv) 30 | 31 | getProgName :: IO String 32 | getProgName = return "" 33 | 34 | getEnv :: String -> IO String 35 | getEnv s = 36 | case System.getenv s of 37 | -- temporary 'new' name until name lookup bug fixed 38 | Nothing -> throwIO (IllegalArgumentException.new s) 39 | Just v -> return v 40 | -------------------------------------------------------------------------------- /frege/system/Exit.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | This package provides compatible definitions for Haskell 2010's 3 | System.Exit by delegating to Java's System.exit function. 4 | 5 | Note that we do not raise an error for attempting to exitWith an 6 | ExitFailure 0 value (like GHC's System.Exit library does). That 7 | seems a rather arbitrary / unnecessary restriction although we 8 | could throw an IllegalArgumentException for it (which still would 9 | not be entirely compatible with Haskell anyway). 10 | --} 11 | module frege.system.Exit where 12 | 13 | import frege.java.Lang 14 | 15 | --- we rely default Eq, Ord, Show implementations - there is no Read yet 16 | data ExitCode = ExitSuccess | ExitFailure Int 17 | derive Eq ExitCode 18 | derive Ord ExitCode 19 | derive Show ExitCode 20 | 21 | exitWith :: ExitCode -> IO a 22 | exitWith ExitSuccess = System.exit 0 >> return undefined 23 | exitWith (ExitFailure n) = System.exit n >> return undefined 24 | 25 | --- exitFail is arbitrarily 1 to indicate a failing exit 26 | exitFailure :: IO a 27 | exitFailure = exitWith (ExitFailure 1) 28 | 29 | exitSuccess :: IO a 30 | exitSuccess = exitWith ExitSuccess 31 | -------------------------------------------------------------------------------- /frege/test/QuickCheckState.fr: -------------------------------------------------------------------------------- 1 | module Test.QuickCheckState where 2 | 3 | import Test.QuickCheckText 4 | import System.Random( StdGen ) 5 | 6 | -- ------------------------------------------------------------------------ 7 | -- State 8 | 9 | -- | State represents QuickCheck's internal state while testing a property. 10 | -- The state is made visible to callback functions. 11 | data State 12 | = MkState 13 | -- static 14 | { terminal :: Terminal -- ^ the current terminal 15 | , maxSuccessTests :: Int -- ^ maximum number of successful tests needed 16 | , maxDiscardedTests :: Int -- ^ maximum number of tests that can be discarded 17 | , computeSize :: Int -> Int -> Int -- ^ how to compute the size of test cases from 18 | -- #tests and #discarded tests 19 | 20 | -- dynamic 21 | , numSuccessTests :: Int -- ^ the current number of tests that have succeeded 22 | , numDiscardedTests :: Int -- ^ the current number of discarded tests 23 | , numRecentlyDiscardedTests :: Int -- ^ the number of discarded tests since the last successful test 24 | , collected :: [[(String,Int)]] -- ^ all labels that have been collected so far 25 | , expectedFailure :: Bool -- ^ indicates if the property is expected to fail 26 | , randomSeed :: StdGen -- ^ the current random seed 27 | 28 | -- shrinking 29 | , numSuccessShrinks :: Int -- ^ number of successful shrinking steps so far 30 | , numTryShrinks :: Int -- ^ number of failed shrinking steps since the last successful shrink 31 | , numTotTryShrinks :: Int -- ^ total number of failed shrinking steps 32 | } 33 | 34 | -- ------------------------------------------------------------------------ 35 | -- the end. -------------------------------------------------------------------------------- /frege/tools/fregedoc.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Frege Documentation 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | <noscript> 13 | <div>JavaScript is disabled on your browser.</div> 14 | </noscript> 15 | <h2>Frame Alert</h2> 16 | <p>This document is designed to be viewed using the frames feature. 17 | If you see this message, you are using a non-frame-capable web client. 18 | Link to <a href="prefix-frame.html">Non-frame version</a>.</p> 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /resources/Frege_logo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Frege/frege/5d9113afcb29739963c234586329dcb5da6b84e9/resources/Frege_logo.jpg -------------------------------------------------------------------------------- /resources/Frege_logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Frege/frege/5d9113afcb29739963c234586329dcb5da6b84e9/resources/Frege_logo.png -------------------------------------------------------------------------------- /resources/Frege_logo_flat_colours.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Frege/frege/5d9113afcb29739963c234586329dcb5da6b84e9/resources/Frege_logo_flat_colours.jpg -------------------------------------------------------------------------------- /resources/Frege_logo_flat_colours.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Frege/frege/5d9113afcb29739963c234586329dcb5da6b84e9/resources/Frege_logo_flat_colours.png -------------------------------------------------------------------------------- /scripts/frege.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | REM *** 3 | REM Frege runscript for Windows 7 4 | REM *** 5 | 6 | setLocal 7 | 8 | if "%FREGE_HOME%" == "" (set FREGE_HOME=build) 9 | 10 | java -cp "%FREGE_HOME%;build" %1 %2 %3 %4 %5 %6 %7 %8 %9 11 | 12 | endlocal -------------------------------------------------------------------------------- /scripts/fregec.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | REM *** 3 | REM Frege compile script for Windows 7 4 | REM *** 5 | 6 | setLocal 7 | 8 | if "%FREGE_HOME%" == "" (set FREGE_HOME=build) 9 | 10 | java -Xmx512m -Xss8m -cp "%FREGE_HOME%;build" frege.compiler.Main -d build -hints %1 %2 %3 %4 %5 %6 %7 %8 %9 11 | 12 | endlocal -------------------------------------------------------------------------------- /scripts/genFunc.pl: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | 3 | use warnings; 4 | use strict; 5 | 6 | my $n = 1; 7 | 8 | 9 | while ($n < 27) { 10 | open J, ">frege/run/Func$n.java" or die "can't open $!"; 11 | my @nargs = map {"final Object arg$_" } (1..$n); 12 | my $cnargs = join (", ", @nargs); 13 | my @args = map { "arg$_" } (1..$n); 14 | my $crargs = join(",", reverse @args); 15 | my $rt = "Object"; 16 | print J <<'LIZENZ'; 17 | /* 18 | 19 | Copyright © 2015 - 2021, Ingo Wechsung 20 | All rights reserved. 21 | 22 | Redistribution and use in source and binary forms, with or 23 | without modification, are permitted provided that the following 24 | conditions are met: 25 | 26 | Redistributions of source code must retain the above copyright 27 | notice, this list of conditions and the following disclaimer. 28 | 29 | Redistributions in binary form must reproduce the above 30 | copyright notice, this list of conditions and the following 31 | disclaimer in the documentation and/or other materials provided 32 | with the distribution. 33 | 34 | Neither the name of the copyright holder 35 | nor the names of its contributors may be used to endorse or 36 | promote products derived from this software without specific 37 | prior written permission. 38 | 39 | THIS SOFTWARE IS PROVIDED BY THE 40 | COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 41 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 42 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 43 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER 44 | OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 45 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 46 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 47 | USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED 48 | AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 49 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 50 | IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF 51 | THE POSSIBILITY OF SUCH DAMAGE. 52 | 53 | */ 54 | 55 | LIZENZ 56 | 57 | print J "package frege.run;\n"; 58 | print J <<"TEXT"; 59 | /** 60 | *

Frege functions with arity $n.

61 | * 62 | *

See {\@link Function} for a general discussion of untyped function values.

63 | * 64 | */ 65 | public interface Func$n extends Function { 66 | /** 67 | *

Apply the function uncurried.

68 | * 69 | * \@return possibly lazy result 70 | */ 71 | public R apply($cnargs); 72 | } 73 | TEXT 74 | close J; 75 | $n++; 76 | } 77 | -------------------------------------------------------------------------------- /scripts/lein-deploy.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # usage: ./scripts/lein-deploy.sh 4 | # 5 | # creates an outline project.clj file based on the current fregec.jar 6 | # version and deploys it to org.frege-lang/frege on Clojars 7 | # 8 | # you must already have a correctly configured Clojars account with 9 | # your deployment keys in place! 10 | 11 | if test -f fregec.jar 12 | then 13 | echo "Found fregec.jar." 14 | else 15 | echo "error: This must be run in the folder that contains fregec.jar." 16 | exit 1 17 | fi 18 | 19 | frege_version=`java -jar fregec.jar -version` 20 | echo "Looks like you have Frege version $frege_version..." 21 | frege_major=`echo $frege_version | sed 's;-.*;;'` 22 | # build project.clj: 23 | ( echo "(defproject org.frege-lang/frege \"${frege_major}-SNAPSHOT\""; 24 | echo ":description \"Frege Compiler and Runtime\""; 25 | echo ":url \"https://github.com/Frege/frege\""; 26 | echo ":license {:name \"BSD 3-clause\""; 27 | echo " :url \"http://opensource.org/licenses/BSD-3-Clause\"}"; 28 | echo ":deploy-repositories {\"snapshots\""; 29 | echo " {:url \"https://oss.sonatype.org/content/repositories/snapshots/\" :creds :gpg}}"; 30 | echo ")" ) > project.clj 31 | echo "" 32 | echo "Here's the project.clj file I built:" 33 | cat project.clj 34 | 35 | # deploy to Sonatype: 36 | echo "" 37 | echo "Attempting to deploy to Sonatype Snapshots..." 38 | lein pom 39 | lein deploy snapshots org.frege-lang/frege ${frege_major}-SNAPSHOT fregec.jar pom.xml 40 | 41 | # cleanup: 42 | rm -rf pom.xml pom.xml.asc project.clj 43 | -------------------------------------------------------------------------------- /scripts/mkdist.pl: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # 7 | # on that damn Windows SUA it insists on having *.exe 8 | # Why can't a giant like Microsoft not have a sound 9 | # POSIX-ish subsystem and a decent shell? 10 | # Its the same sh*t like in Windows 95. 11 | # They've done barely anything in almost 20 years. 12 | # 13 | my $exe = ""; 14 | $exe = ".exe" unless defined $ENV{SHELL} and length $ENV{SHELL} > 0; 15 | 16 | mkdir "dist" unless -d "dist"; 17 | 18 | # remove all java source files from the distribution, they're big 19 | system (qq{find$exe}.q{ build/frege -name "*.java" -exec rm "{}" ";"}); 20 | 21 | # find out the version 22 | my $version = qx{java$exe -cp build frege.compiler.Main -version | head -1}; 23 | chomp $version; 24 | $version =~ s/\s//g; 25 | my $latest = $version; 26 | $latest =~ s/^(3\.\d+)\.\d+(.*)/$1-latest$2/; 27 | print "making dist for version: '$version'\n"; 28 | 29 | 30 | 31 | # make "executable" frege*.jar 32 | chdir "./build"; 33 | my $entrypoint = -f 'frege/Starter.class' ? "frege.Starter" : "frege.compiler.Main"; 34 | # open MANI, ">manifest.txt"; 35 | # print MANI "Manifest-Version: 1.0\n"; 36 | # print MANI "Main-Class: $entrypoint\n"; 37 | # print MANI "Class-Path: jline-2.14.6.jar\n"; 38 | # close MANI; 39 | system qq{jar$exe -xf ../lib/jline-2.14.6.jar} if -f "../lib/jline-2.14.6.jar" && -d "frege/repl"; 40 | unlink "META-INF/MANIFEST.MF"; 41 | system qq{jar$exe -cfe ../dist/frege$version.jar $entrypoint frege/ jline/ org/ META-INF/}; 42 | chdir ".."; 43 | 44 | # ship documentation 45 | # sometimes it's good to have it offline 46 | # system qq{jar$exe -cf dist/htmldocs$version.zip doc/frege doc/*.html doc/*.css doc/package-list}; 47 | 48 | # 49 | # Collect and jar the library sources. 50 | # These can be downloaded in order to make 51 | # a pseudo Eclipse project, so navigation 52 | # to library source code will be possible. 53 | # 54 | my @frsrcs = grep { $_ !~ m{frege/(contrib|compiler|rt)/|frege/Scrap} } 55 | (split /\s+/, qx{find$exe frege -name "*.fr" -print}); 56 | system qq{jar$exe -uf dist/frege$version.jar @frsrcs}; 57 | system qq{ln$exe -f dist/frege$version.jar dist/frege$latest.jar}; 58 | my $pwd = `pwd$exe`; chomp $pwd; 59 | print "you can reference this also with $pwd/dist/frege$latest.jar\n"; 60 | -------------------------------------------------------------------------------- /scripts/mkmk.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | while (<>) { 7 | m/^JAVAC5/ and do { print "JAVAC5 = echo no java5 here\n"; next }; 8 | s/pbyacc/byaccj/; 9 | # s/\bMakefile\b/frege.mk/; 10 | s/\.;build/.:build/; 11 | s/shadow;/shadow:/; 12 | print; 13 | } 14 | 15 | -------------------------------------------------------------------------------- /scripts/mkversion.pl: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | 3 | 4 | use strict; 5 | use warnings; 6 | 7 | 8 | my $version = qx{git describe --long}; 9 | my $commit = qx{git log -n 1}; 10 | chomp $version; 11 | chomp $commit; 12 | $version =~ s/-(\d+)-.*$/.$1/; 13 | $commit =~ s/\n/\\n/g; 14 | $commit =~ s/\r//g; 15 | $commit =~ s/"/\\"/g; 16 | $commit =~ s/<[^>]*>//; 17 | print < 0; 15 | 16 | sub run { 17 | my $cmd = shift; 18 | print "\t", $cmd, "\n"; 19 | system $cmd; 20 | } 21 | 22 | # make sure subdir save exists and is empty 23 | run qq{rm$exe -rf save}; 24 | mkdir "save" unless -d "save"; 25 | 26 | # collect all java sources in build/frege 27 | chdir "build"; 28 | my @js = split /\s+/, qx{find$exe frege -name "*.java" -print}; 29 | # pack them in a jar 30 | run qq{jar$exe -cf ../temp.jar @js}; 31 | 32 | chdir ".." and run qq{jar$exe -uf temp.jar frege/runtime}; 33 | chdir "save" and run qq{jar$exe -xf ../temp.jar}; 34 | unlink "../temp.jar"; 35 | chdir ".." and run qq{rm$exe -rf save/META-INF}; -------------------------------------------------------------------------------- /tests/comp/Dezi.fr: -------------------------------------------------------------------------------- 1 | --- This is an undocumented module 2 | module tests.comp.Dezi where 3 | 4 | 5 | foo :: Decimal → Decimal 6 | foo z = z 7 | 8 | bar = foo 123.456e-111z 9 | 10 | main = println bar -------------------------------------------------------------------------------- /tests/comp/I61Java.java: -------------------------------------------------------------------------------- 1 | package tests.comp; 2 | 3 | /** 4 | *

Test class to demonstrate that $ in method names and member names work.

5 | * @author ingo 6 | * 7 | */ 8 | final public class I61Java { 9 | final public int mem$1; 10 | final public int $getMem1$() { return mem$1;} 11 | public I61Java(int arg) { mem$1 = arg; } 12 | } 13 | -------------------------------------------------------------------------------- /tests/comp/Issue103.fr: -------------------------------------------------------------------------------- 1 | --- Code for 'https://github.com/Frege/frege/issues/103 Issue 103' 2 | module tests.comp.Issue103 where 3 | 4 | --- Tail recursion must pass an updated context in each turn. 5 | --- Note that the value that is finally shown is of type 6 | --- > [[[ ... 𝖆 ... ]]] 7 | --- where the 'Int' argument determines the number of @[]@ pairs. 8 | --- In the 3.22 release, this works only when there is no tail recursion. 9 | nested ∷ Show 𝖆 ⇒ Int → 𝖆 → String 10 | nested 0 x = show x 11 | nested n x = nested (n-1) (x,x) 12 | -- when polymorphic tail recursion works, 13 | -- the following line can be commented 14 | -- ++ "" 15 | 16 | main [arg] = do 17 | println "module Stress where" 18 | print "val = " 19 | println (nested (atoi arg) true) 20 | main _ = main ["3"] 21 | -------------------------------------------------------------------------------- /tests/comp/Issue126.fr: -------------------------------------------------------------------------------- 1 | --- Example code for Issue 126 2 | module tests.comp.Issue126 where 3 | 4 | import frege.Prelude hiding(Byte) 5 | -- import Data.List 6 | 7 | data Byte = pure native "byte" where 8 | pure native byte "(byte)" :: Int -> Byte 9 | --- this gives the 'Int' corresponding to the *signed* interpretation of the 'Byte' 10 | pure native signed "(int)" :: Byte -> Int 11 | --- this gives the 'Int' corresponding to the *unsigned* interpretation of the 'Byte' 12 | unsigned b = signed b Int..&. 0xFF 13 | hashCode = Byte.unsigned 14 | 15 | instance Eq Byte where 16 | -- hashCode = Byte.unsigned 17 | pure native == :: Byte -> Byte -> Bool 18 | pure native != :: Byte -> Byte -> Bool 19 | 20 | main = print (hashCode (Byte.byte 142)) >> println " (should be 142)" -------------------------------------------------------------------------------- /tests/comp/Issue152.fr: -------------------------------------------------------------------------------- 1 | --- Demonstrate working of "MonadFail" issue 2 | module tests.comp.Issue152 where 3 | 4 | 5 | foo xs = [ 2*x | ("this", x) <- xs ] 6 | bar xs = do { ("this", x) <- xs; return (2*x) } 7 | 8 | items = [("this", 21), ("that", 1)] 9 | 10 | main = do 11 | println $ foo items -- [42] 12 | println $ bar items -- used to abort due to pattern match failure 13 | println $ bar (Just ("this", 21)) -- Just 42 14 | println $ (bar (Right ("that", 21)) :: (String | Int)) -- Left "pattern match failure ..." 15 | -- don't disturb interactive regression 16 | -- println "Enter \"quit\" for graceful exit, anything else for abortion." 17 | -- "quit" <- getLine 18 | pure () -------------------------------------------------------------------------------- /tests/comp/Issue158.fr: -------------------------------------------------------------------------------- 1 | --- Wrong precedence for - in, for example, 1-2*3 2 | module tests.comp.Issue158 where 3 | 4 | main = do 5 | print "The result should be -5: " 6 | println (1-2*3) 7 | -------------------------------------------------------------------------------- /tests/comp/Issue160.fr: -------------------------------------------------------------------------------- 1 | --- 'https://github.com/Frege/frege/issues/160 Illegal Java code for polymorphic constrained non-function field' 2 | module tests.comp.Issue160 where 3 | 4 | {-- 5 | Wrong code for the change function is generated, 6 | which tries to apply a context to an Object (i.e. the 'Showable.wrong' member) 7 | -} 8 | -- data Showable = S { flag :: Bool, wrong :: (forall a. Show a => a) } 9 | 10 | --- Even more reduced 11 | data S2 = S2 Bool (forall a.Show a => a) 12 | 13 | trythis :: S2 -> String 14 | trythis v = case v of 15 | S2 _ x -> x 16 | 17 | main = println "Ok" -- can not construct an S2 18 | -------------------------------------------------------------------------------- /tests/comp/Issue169.fr: -------------------------------------------------------------------------------- 1 | --- When top level definitions are not lazy enough, this program may hang. 2 | module tests.comp.Issue169 where 3 | 4 | import frege.lib.ForkJoin(mapP) 5 | 6 | doSomething :: Int → Int 7 | doSomething x = x * x 8 | 9 | -- sumOther = sum (map doSomething [1,2,3]) 10 | sumNumbers = sum (mapP doSomething [9, 10, 3, 4]) 11 | 12 | 13 | main args = do 14 | -- let 15 | -- sumSquares = sum ( mapP doSomething [9, 10, 3, 4, 7, 3, 49, 10, 3, 4, 7, 3, 49, 10, 3, 4, 7, 3, 4, 10] ) 16 | -- println sumOther 17 | println (sumNumbers) 18 | -------------------------------------------------------------------------------- /tests/comp/Issue20.fr: -------------------------------------------------------------------------------- 1 | --- 'https://github.com/Frege/frege/issues/20 Better java support' 2 | module tests.comp.Issue20 where 3 | 4 | import Java.Util 5 | 6 | native module 7 | -- type Object 8 | -- interface Comparator Int, Comparable String 9 | where { 10 | // Be careful with comments, no unpaired braces, please! 11 | // And also no pre- or post-decrement, because this would be a Frege comment! 12 | // You can write \u002d\u002d if you must. 13 | 14 | public static class FComp implements java.util.Comparator { 15 | final private Func.U> f; 16 | final public int compare(final A arg$1, final A arg$2) { 17 | return Prelude.IEnum_Ordering.ord( 18 | f.apply(Thunk.lazy(arg$1)).call() 19 | .apply(Thunk.lazy(arg$2)).call() 20 | ) - 1; 21 | } 22 | public FComp(Func.U> x) { f = x; } 23 | public static java.util.Comparator mk(Func.U> f) { 24 | return new FComp(f); 25 | } 26 | public int compareTo(Object other) { return -1; } 27 | } 28 | } 29 | 30 | pure native mkComparator FComp.mk{a} :: (a -> a -> Ordering) -> Comparator a 31 | 32 | compareFst :: (Int, a) -> (Int, a) -> Ordering 33 | compareFst = comparing fst 34 | 35 | main = do 36 | let stringComparator = mkComparator (String.<=>) 37 | tupleComparator = mkComparator compareFst 38 | println (stringComparator.compare "foo" "bar") 39 | println (tupleComparator.compare (42, "foo") (43, "bar")) 40 | -------------------------------------------------------------------------------- /tests/comp/Issue203.fr: -------------------------------------------------------------------------------- 1 | --- Check resolution for 'https://github.com/Frege/frege/issues/203 Issue 203' 2 | module tests.comp.Issue203 where 3 | 4 | data R a = R { v :: a, f :: forall b.a -> [b] -> [b] } 5 | 6 | x = R 42 drop 7 | 8 | y = x.{f <- \f i -> drop i . f i} 9 | 10 | z = x.{f = take} 11 | 12 | main = do 13 | println (x.f 10 (replicate 13 "3×Ok")) 14 | println (y.f 10 (replicate 23 "3×Ok")) 15 | println (z.f 3 (repeat "3×Ok")) -------------------------------------------------------------------------------- /tests/comp/Issue21.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | Should compile if type aliases work more like macros like in 3 | http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#type-synonyms 4 | -} 5 | module tests.comp.Issue21 where 6 | 7 | --- Lens type 8 | type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s 9 | 10 | --- You can write a forall (including overloading) in a type synonym, thus: 11 | type Discard a = forall b. Show b => a -> b -> (a, String) 12 | 13 | 14 | 15 | f :: Discard c 16 | -- f :: forall b c. Show b => c -> b -> (c, String) 17 | f x y = (x, show y) 18 | 19 | g :: Discard Int -> (Int,String) -- A rank-2 type 20 | -- g :: (forall b . Show b => Int -> b -> (Int, String)) -> (Int, String) 21 | g f = f 3 true 22 | 23 | h = g f 24 | 25 | 26 | main _ = println h -------------------------------------------------------------------------------- /tests/comp/Issue234.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | Test code for for 'https://github.com/Frege/frege/issues/234 Issue 234' 3 | 4 | This code used to complain about ambiguous overloads: 5 | 6 | > overloaded new is ambiguous at type String→U 7 | > It could mean one of 8 | > U.newα :: String → U 9 | > U.newβ :: String → Throwable → U 10 | > A.new :: String → U 11 | -} 12 | 13 | module tests.comp.Issue234 where 14 | 15 | data U = pure native frege.runtime.Undefined where 16 | pure native new :: String -> U | String -> Throwable -> U 17 | 18 | data A = pure native java.lang.IllegalArgumentException where 19 | pure native new :: String -> U 20 | 21 | x = U.new "foo" :: U 22 | 23 | main = println "Ok, since compiled." 24 | -------------------------------------------------------------------------------- /tests/comp/Issue257.fr: -------------------------------------------------------------------------------- 1 | --- See 'https://github.com/Frege/frege/issues/257 Issue 257' 2 | module tests.comp.Issue257 where 3 | 4 | type Lens s t a b = forall f . Functor f => (a -> f b) -> (s -> f s) 5 | 6 | foo :: Lens String () Bool Char 7 | foo x i = fmap (const i) (x true) 8 | 9 | bar = const (Just 'c') 10 | 11 | main = println (foo bar "Okay") 12 | -------------------------------------------------------------------------------- /tests/comp/Issue258.fr: -------------------------------------------------------------------------------- 1 | --- Compiler should fail on type Stream, since (Cons a (Cons a)) is a kind error 2 | --- Compiler complains only when 'infinite' is uncommented. 3 | --- (Should this be in nocomp?) 4 | 5 | module tests.comp.Issue258 where 6 | 7 | 8 | type Omega s = s s 9 | 10 | data Cons a b = Cons a b 11 | 12 | type Stream a = Omega (Cons a) 13 | 14 | 15 | --infinite :: a -> Stream a 16 | --infinite x = undefined 17 | 18 | data Const a b = Const { getConst :: a } 19 | 20 | main :: IO Bool 21 | main = println "This should not compile." >> pure true -------------------------------------------------------------------------------- /tests/comp/Issue26.fr: -------------------------------------------------------------------------------- 1 | --- implemented negative patterns 2 | module tests.comp.Issue26 where 3 | 4 | -- next gives message: "only numeric patterns may be negated" 5 | --wrong (-"bar") = "xx" 6 | 7 | foo (-42n) = "Okay" 8 | foo _ = "Not OK" 9 | 10 | bar (-42) = "Okay" 11 | bar _ = "Not OK" 12 | 13 | baz (-42.0) = "Okay" 14 | baz _ = "Not OK" 15 | 16 | main ∷ IO Bool 17 | main = do 18 | println (foo (-42n)) 19 | println (bar (-42)) 20 | println (baz (-42.0)) 21 | pure (foo (-42n) == "Okay" && bar (-42) == "Okay" && baz (-42.0) == "Okay") 22 | -------------------------------------------------------------------------------- /tests/comp/Issue260.fr: -------------------------------------------------------------------------------- 1 | --- Minimal example for 'https://github.com/Frege/frege/issues/260 Issue 260' 2 | module tests.comp.Issue260 where 3 | 4 | data MyT a = MyT where 5 | phantomString = MyT :: MyT String 6 | 7 | main = println "Compiled, so okay" -------------------------------------------------------------------------------- /tests/comp/Issue271.fr: -------------------------------------------------------------------------------- 1 | --- See 'https://github.com/Frege/frege/issues/271 Issue #271' 2 | --- - Compiler issues a guard-may-fail warning, despite default case available. 3 | --- - Should print Nothing, but dies of tuple pattern not matched 4 | 5 | --- Turns out that the pattern binding in the first clause of 'readDriveShare' morphs to 6 | --- > readDriveShare (x:xs) = let u = (['f', 'g']) in 7 | --- > case u of (a,_) -> case u of (_,b) | x == '/' = Just (x:a,b) 8 | --- and this wrongly attaches the guard to the wrong case clause. 9 | 10 | --- Solution: drop the special handling of 11 | --- > let a = case ... in ... 12 | --- It didn't play well with laziness anyway. 13 | 14 | module tests.comp.Issue271 where 15 | 16 | 17 | readDriveShare (x:xs) | x == '/' = b 18 | where 19 | (a,b) = (['f'], undefined) 20 | -- a = case (['f'],['g']) of (a,_) = a 21 | -- b = case (['f'],['g']) of (_,b) = b 22 | 23 | readDriveShare _ = "Ok" 24 | 25 | main = println $ readDriveShare (toList "file") 26 | 27 | simpler (s:ss) | s == "foo" = (b,a) where (a,b) = (42,true) 28 | simpler _ = (false, 0) -------------------------------------------------------------------------------- /tests/comp/Issue273.fr: -------------------------------------------------------------------------------- 1 | {-- 'https://github.com/Frege/frege/issues/273 Issue 273' 2 | 3 | Problem: functions don't type check, because the higher ranked 4 | function argument gets stuffed into a tuple for pattern matching by desugaring. 5 | 6 | Desugaring can't make it right in the first place since there may be 7 | constructors whose arity we don't know yet. 8 | 9 | Solution: Compile the tuple pattern matches *before* type checking. 10 | -} 11 | 12 | module tests.comp.Issue273 where 13 | 14 | gfoldl :: (forall d b. Maybe (d -> b) -> d -> Maybe b) 15 | -> (forall g. g -> Maybe g) 16 | -> [a] 17 | -> Maybe [a] 18 | 19 | 20 | gfoldl f z [] = z [] 21 | gfoldl f z (y:ys) = (z (:) `f` y) 22 | -- ^^^^^^^^^^^ 23 | `f` ys 24 | -- ^^ 25 | 26 | 27 | 28 | bar (Just x) false = "no" 29 | bar _ true = "yes" 30 | 31 | main = println (bar (Just 42) true) -- "yes" 32 | 33 | 34 | -------------------------------------------------------------------------------- /tests/comp/Issue277.fr: -------------------------------------------------------------------------------- 1 | --- Test case for 'https://github.com/Frege/frege/issues/277 Issue 277' 2 | {-- 3 | > frege.runtime.Undefined: Can't adapt 4 | > Bind {a → a, Func.U<𝓐, 𝓐>, RunTM., Func.U<𝓐, 𝓐>>>cast(arg$1) 5 | > .apply(Thunk.>lazy(ctx$1)).call()} 6 | > to Func.U, Func.U> 7 | > because 𝓐 does not match CData 8 | 9 | when generating code for the equation of 'everywhere' 10 | -} 11 | 12 | module tests.comp.Issue277 where 13 | 14 | import Data.Maybe 15 | 16 | main = print $ invert [-1,0,1] 17 | 18 | invert :: Data a => a -> a 19 | invert = everywhere (mkT inv) 20 | where 21 | inv :: Int -> Int 22 | inv i = -i 23 | 24 | -- from the original Data class in ghc and 25 | -- https://github.com/rdegnan/typeable 26 | everywhere :: 27 | (forall a. Data a => a -> a) -- this usedto provoke the compiler abort 28 | -- (forall x. Data x => x -> x) -- replace a/x and it used to work correctly 29 | -> (forall a. Data a => a -> a) 30 | everywhere f = f . gmapT (everywhere f) 31 | 32 | mkT :: ( Typeable a 33 | , Typeable b 34 | ) 35 | => (b -> b) 36 | -> a 37 | -> a 38 | mkT = extT id 39 | 40 | extT :: ( Typeable a 41 | , Typeable b 42 | ) 43 | => (a -> a) 44 | -> (b -> b) 45 | -> a 46 | -> a 47 | extT def ext = (T.unT) ((T def) `ext0` (T ext)) 48 | 49 | ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a 50 | ext0 def ext = maybe def id (gcast ext) 51 | 52 | gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b) 53 | gcast x = r 54 | where 55 | unsafeCoerce = unsafeCoerce_ 56 | r = if typeOf (getArg x) == typeOf (getArg (fromJust r)) 57 | then Just $ unsafeCoerce x 58 | else Nothing 59 | getArg :: c x -> x 60 | getArg = undefined 61 | 62 | pure native unsafeCoerce_ java.util.Objects.requireNonNull {a} :: a -> b 63 | 64 | data T x = T { unT :: x -> x } 65 | data ID x = ID { unID :: x } 66 | 67 | instance Data a => Data [a] where 68 | gmapT f x = case x of 69 | [] -> [] 70 | (y:ys) -> (f y:f ys) 71 | 72 | instance Data Int 73 | 74 | class Typeable a => Data a where 75 | gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) 76 | -> (forall g. g -> c g) 77 | -> a 78 | -> c a 79 | gfoldl _ z = z 80 | gmapT :: (forall b. Data b => b -> b) -> a -> a 81 | gmapT f x0 = (ID.unID) (gfoldl (\(ID c) x -> ID (c (f x))) ID x0) 82 | 83 | instance Typeable a => Typeable ([] a) where 84 | typeOf _ = "prelude.List.Int" 85 | instance Typeable Int where 86 | typeOf _ = "prelude.Int" 87 | 88 | class Typeable a where 89 | typeOf :: a -> String 90 | -------------------------------------------------------------------------------- /tests/comp/Issue277a.fr: -------------------------------------------------------------------------------- 1 | --- This is an undocumented module 2 | module tests.comp.Issue277a where 3 | 4 | class Bar c 5 | 6 | -- this works 7 | -- foo :: (forall b. Bar b => b -> b) -> (forall a. a -> a) 8 | -- this crashed in code generation 9 | foo :: (forall a. Bar a => a -> a) -> (forall a.a -> a) 10 | foo f = foo f 11 | 12 | gid :: (∀ a. Bar a => a -> a) -> (∀ a. Bar a => a -> a) 13 | gid f = f 14 | 15 | main = println "Compiled, ok" -------------------------------------------------------------------------------- /tests/comp/Issue278.fr: -------------------------------------------------------------------------------- 1 | --- 'https://github.com/Frege/frege/issues/278 Sigma problems' 2 | module tests.comp.Issue278 where 3 | 4 | import Data.List 5 | 6 | problem1 ∷ (forall a. a->a) -> a -> b -> (a,b) 7 | -- ^^^^ bound type variable(s) a not appearing in type 8 | problem1 f x y = (f x, f y) 9 | 10 | 11 | 12 | import frege.data.wrapper.Const 13 | import frege.data.wrapper.Identity 14 | 15 | type Lens s a = forall f. Functor f => (a -> f a) -> s -> f s 16 | 17 | view :: Lens s a -> (s -> a) 18 | view lens = Const.get . lens Const 19 | 20 | set :: Lens s a -> (a -> s -> s) 21 | set lens x = over lens (const x) 22 | 23 | over :: Lens s a -> (a -> a) -> s -> s 24 | over lens f = Identity.run . lens (Identity . f) 25 | 26 | data Bank = Bank { client :: Client } 27 | data Client = Client { portfolio :: Portfolio } 28 | data Portfolio = Portfolio { position :: Position } 29 | data Position = Position { soMany :: Int } 30 | 31 | soManyLens :: Lens Position Int 32 | soManyLens f p = fmap p.{soMany =} (f p.soMany) 33 | 34 | positionLens :: Lens Portfolio Position 35 | positionLens f p = fmap p.{position =} (f p.position) 36 | 37 | portfolioLens :: Lens Client Portfolio 38 | portfolioLens f c = fmap c.{portfolio =} (f c.portfolio) 39 | 40 | clientLens :: Lens Bank Client 41 | clientLens f b = fmap b.{client =} (f b.client) 42 | 43 | derive Show Bank 44 | derive Show Client 45 | derive Show Portfolio 46 | derive Show Position 47 | 48 | bank = Bank { 49 | client = Client { 50 | portfolio = Portfolio { 51 | position = Position { soMany = 0 } 52 | } 53 | } 54 | } 55 | 56 | main _ = do 57 | position = Position 0 58 | portfolio = Portfolio position 59 | println $ view soManyLens position 60 | println $ set soManyLens 1 position 61 | println $ over soManyLens (+2) position 62 | 63 | println $ view (positionLens . soManyLens) portfolio 64 | println $ set (positionLens . soManyLens) 3 portfolio 65 | println $ over (positionLens . soManyLens) (+4) portfolio 66 | 67 | let deepLens ∷ Functor f => (Int→f Int)→Bank→f Bank 68 | deepLens = clientLens . portfolioLens . positionLens . soManyLens 69 | println $ view deepLens bank 70 | println $ set deepLens 5 bank 71 | println $ over deepLens (+6) bank 72 | -------------------------------------------------------------------------------- /tests/comp/Issue284.fr: -------------------------------------------------------------------------------- 1 | --- https://github.com/Frege/frege/issues/284 Issue 284 2 | module tests.comp.Issue284 where 3 | 4 | data Generic' c = Generic' { unGeneric' :: Maybe c } 5 | 6 | access :: Generic' a -> Maybe a 7 | access x = x.unGeneric' 8 | 9 | match :: Generic' a -> Maybe a 10 | match (Generic'{unGeneric'}) = unGeneric' 11 | 12 | match' :: Generic' a -> Maybe a 13 | match' (Generic'{unGeneric'=a}) = a 14 | 15 | update :: b -> Generic' a -> Generic' b 16 | update b x = x.{ unGeneric' = Just b } 17 | 18 | change :: (a -> b) -> Generic' a -> Generic' b 19 | change f x = x.{ unGeneric' <- fmap f } 20 | 21 | 22 | main = println (access (Generic' (Just "O'kay"))) -------------------------------------------------------------------------------- /tests/comp/Issue284a.fr: -------------------------------------------------------------------------------- 1 | --- https://github.com/Frege/frege/issues/284 Issue 284 2 | --- 3 | --- Tests that imported record can be used even if mangled. 4 | module tests.comp.Issue284a where 5 | 6 | import tests.comp.Issue284 (Generic') 7 | 8 | access :: Generic' a -> Maybe a 9 | access x = x.unGeneric' 10 | 11 | match :: Generic' a -> Maybe a 12 | match (Generic'{unGeneric'}) = unGeneric' 13 | 14 | match' :: Generic' a -> Maybe a 15 | match' (Generic'{unGeneric'=a}) = a 16 | 17 | update :: b -> Generic' a -> Generic' b 18 | update b x = x.{ unGeneric' = Just b } 19 | 20 | change :: (a -> b) -> Generic' a -> Generic' b 21 | change f x = x.{ unGeneric' <- fmap f } 22 | 23 | main = println (access (Generic' (Just "also O'kay"))) -------------------------------------------------------------------------------- /tests/comp/Issue290.fr: -------------------------------------------------------------------------------- 1 | --- see also 'https://github.com/Frege/frege/issues/290 Issue 290' 2 | --- support strictness annotations in unnamed constructor fields 3 | module tests.comp.Issue290 where 4 | 5 | data Issue290 = Issue290 !String ?Int 6 | 7 | unfein = Issue290 "Okay" (42 `quot` 0) 8 | 9 | main :: IO Bool 10 | main = case unfein of 11 | -- the following line would first print "Okay" and only then die from evaluating 42/0 12 | -- Issue290 s x → println s >> pure (x > 7) 13 | -- the following line does not evaluate the int field 14 | Issue290 s x → println s >> pure true -------------------------------------------------------------------------------- /tests/comp/Issue294.fr: -------------------------------------------------------------------------------- 1 | --- Issue 294, code generation aborts with "can't adapt" 2 | --- when undefined is assigned a constrained type 3 | module tests.comp.Issue294 where 4 | 5 | schlecht :: Eq a => a -> a 6 | schlecht = undefined 7 | 8 | -- the following is fine instead 9 | -- schlecht x = undefined x 10 | 11 | 12 | 13 | main = println true -------------------------------------------------------------------------------- /tests/comp/Issue296.fr: -------------------------------------------------------------------------------- 1 | module tests.comp.Issue296 where 2 | 3 | data RType = DeadEnd | WinningCycle | LosingCycle 4 | 5 | derive Show RType 6 | 7 | exampleGood :: (RType, ()) 8 | exampleGood = (l w', ()) where 9 | l true = WinningCycle 10 | l false = LosingCycle 11 | w' = if true then false else true 12 | 13 | exampleBad :: (RType, ()) 14 | exampleBad = (if w' then LosingCycle else WinningCycle, ()) where 15 | w' = if true then false else true 16 | 17 | main = println exampleBad -------------------------------------------------------------------------------- /tests/comp/Issue297.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | when compiling with -O 3 | 4 | > E tests/comp/Issue297.fr:18: Cannot make lambda that has no function type 5 | > λv2338 -> mkT id' (mkT id' v2338) :: a → a @@ Lazy 6 | 7 | See 'https://github.com/Frege/frege/issues/297 #297' 8 | -} 9 | 10 | module tests.comp.Issue297 where 11 | 12 | import frege.Prelude hiding(apply) 13 | 14 | main = print $ apply [-1,0,1] 15 | 16 | apply :: Show aa => aa -> aa 17 | -- apply = everywhere (\x → mkT id' ( mkT id' x)) -- works! 18 | apply = everywhere (mkT id' . mkT id') -- context supplied by typecheck gets lost 19 | where 20 | id' :: Int -> Int 21 | id' = id 22 | 23 | everywhere :: (forall a. Show a => a -> a) -> (forall c. Show c => c -> c) 24 | everywhere f = f 25 | 26 | mkT :: (Show a, Show b) => (b -> b) -> a -> a 27 | mkT a1 a2 = a2 28 | -------------------------------------------------------------------------------- /tests/comp/Issue298.fr: -------------------------------------------------------------------------------- 1 | --- see 'https://github.com/Frege/frege/issues/298 Issue 298' 2 | --- Adapt default precedence and associativity to Haskell2010 standard: 3 | --- If no fixity declaration is given for op then it defaults to highest precedence and left associativity. 4 | module tests.comp.Issue298 where 5 | 6 | --- when op is used as operator, it'll bind more tightly than multiplication 7 | op a b = a + b 8 | 9 | example1 = 3 * 4 `op` 5 `op` 6 -- should be 45 10 | example2 = 3 * 4 + 5 + 6 -- should be 23 11 | 12 | (###) = (,) 13 | 14 | also ∷ ((Int,Bool),Char) 15 | also = 1 ### true ### 'c' 16 | 17 | main :: IO Bool 18 | main = pure (example1 == 45 && example2 == 23) 19 | 20 | -------------------------------------------------------------------------------- /tests/comp/Issue301.fr: -------------------------------------------------------------------------------- 1 | --- Incompatibility of function 'words' with Haskell 2 | --- see 'https://github.com/Frege/frege/issues/301 issue 301' 3 | module tests.comp.Issue301 where 4 | 5 | main = do 6 | println ("Expected: " ++ show expected) 7 | println ("Got: " ++ show result) 8 | println ("Apparently, the words function is " 9 | ++ (if result == expected then "fully" else "not") 10 | ++ " compatible with Haskell2010.") 11 | where 12 | result = words " one two three" 13 | expected = ["one", "two", "three"] 14 | -------------------------------------------------------------------------------- /tests/comp/Issue313.fr: -------------------------------------------------------------------------------- 1 | --- Code for 'https://github.com/Frege/frege/issues/313 Issue 313' 2 | module tests.comp.Issue313 where 3 | 4 | data Empty 5 | 6 | main = println "Yes, we can make a nullary data type." -------------------------------------------------------------------------------- /tests/comp/Issue323.fr: -------------------------------------------------------------------------------- 1 | --- This is an undocumented module 2 | module tests.comp.Issue323 where 3 | 4 | import Control.Arrow 5 | 6 | -- "type class" 7 | class Arrow a => ArrowApply a where 8 | app :: a (a b c, b) c 9 | 10 | -- "instance" for (->) 11 | instance ArrowApply (->) where 12 | app :: (b -> c, b) -> c 13 | app (f, b) = arr f b 14 | 15 | -- use it 16 | main = println (app ((1+), 3)) -------------------------------------------------------------------------------- /tests/comp/Issue332.fr: -------------------------------------------------------------------------------- 1 | --- Code for 'https://github.com/Frege/frege/issues/332 Issue 332' 2 | module tests.comp.Issue332 where 3 | 4 | data I332Java a = pure native java.util.List 5 | 6 | derive JavaType (I332Java a) 7 | derive ArrayElement (I332Java a) 8 | 9 | main = println "Yes, we can derive ArrayElement for generic Java type." -------------------------------------------------------------------------------- /tests/comp/Issue333.fr: -------------------------------------------------------------------------------- 1 | --- Inconvenience in the pattern compiler 2 | --- This code shouldn't give a warning 3 | module tests.comp.Issue333 where 4 | 5 | data Test = Test { x :: Int } 6 | 7 | foo :: Test -> [Int] -> IO () 8 | foo _ [] = pure () 9 | foo (t@Test{}) (y:ys) = foo t ys 10 | 11 | -- the example is a bit contrieved, however we could cover it 12 | -- by checking the second columns of patterns first: 13 | 14 | oof [] _ = pure () 15 | oof (y:ys) (t@Test{}) = foo t ys 16 | 17 | {- 18 | more generally, whenever we see that the first column 19 | of patterns is not homogenous, we could instead look 20 | for another column that is homogenous and check that one first. 21 | That is 22 | 23 | case (a,b) of 24 | (X, Con1) -> ex1 25 | (v2, Con2) -> ex2 26 | (Y, Con1) -> ex3 27 | 28 | would be transformed to 29 | 30 | case (b,a) of 31 | (Con1, X) -> ex1 32 | (Con2, v2) -> ex2 33 | (Con1, Y) -> ex3 34 | 35 | and the pattern compiler would give us 36 | 37 | case b of 38 | Con1 -> case a of 39 | X -> ex1 40 | Y -> ex3 41 | Con2 -> case a of 42 | v2 -> ex2 43 | 44 | 45 | -} 46 | 47 | cons (Just Nothing) _ = 1 48 | cons (Just a) _ = 2 49 | cons Nothing _ = 3 50 | 51 | --- More general case: patterns are complete, and yet there are two warnings! 52 | general Nothing [] = 42 53 | general _ (_:_) = 43 54 | general (Just _) 55 | [] = 44 56 | 57 | --- and the reverse case that has no warnings 58 | lareneg [] Nothing = 42 59 | lareneg (_:_) _ = 43 60 | lareneg [] (Just _) = 44 61 | 62 | main = println "No warning anymore for foo, lines 7-9" -------------------------------------------------------------------------------- /tests/comp/Issue336.fr: -------------------------------------------------------------------------------- 1 | --- Test case for 'https://github.com/Frege/frege/issues/336 #336' 2 | {-- 3 | Annotated constraint got lost when right hand side written in point free style 4 | didn't mention the higher rank constrained argument. That is, with 5 | 6 | > foo ∷ (∀a. Something a ⇒ a → a) → [b→b] 7 | 8 | the typechecker was happy. But note that the higher ranked function passed as argument to @foo@ 9 | needs to get instantiated at some type (here "b") when passed to @pure@ (as @pure@ does not expect 10 | a higher ranked function). Such instantiation on constrained types implies that a 11 | dictionary must be passed to satisfy the constraints (here @Something a@). And this 12 | dictionary can only come from the caller of @foo@, who knows what @b@ actually is. 13 | Hence, @Something b@ must occur in the type for @foo@. 14 | 15 | This type error was flagged only when the definition did mention the argument, for example: 16 | 17 | > foo f = pure f 18 | 19 | but not when it was written in the short form. 20 | -} 21 | module tests.comp.Issue336 where 22 | 23 | foo :: (∀ a. Something a ⇒ a → a) → (∀ b. Something b ⇒ [b → b]) 24 | foo = pure 25 | 26 | bar :: (∀ a. Something a ⇒ (∀ b. Something b ⇒ (∀ c. Something c ⇒ c → c) → b → b) → a → a) 27 | bar f a = f identity a 28 | 29 | -- for easier tracing, we dont use standard id which has a more complex type 30 | 31 | identity x = x 32 | 33 | class Something a 34 | 35 | instance Something String 36 | 37 | main = do 38 | println ( head (foo identity) "Ok" ) -- head [identity] "Ok" 39 | println ( bar identity "Ok" ) -- identity identity "Ok" 40 | -------------------------------------------------------------------------------- /tests/comp/Issue345.fr: -------------------------------------------------------------------------------- 1 | --- annotated foo = empty generates wrong java code unless same type variables as in original are used 2 | module tests.comp.Issue345 where 3 | 4 | class Leer a where 5 | wüst :: a b 6 | 7 | instance Leer Maybe where 8 | wüst = Nothing 9 | 10 | --- this compiles 11 | leer :: Leer x ⇒ x y 12 | leer = wüst 13 | 14 | --- this didn't (because ListEmpty is special) 15 | empty' :: ListEmpty α ⇒ α y 16 | empty' = empty 17 | 18 | 19 | --- neither this one 20 | epair ∷ (ListEmpty m, ListEmpty n) ⇒ (m Int, n Bool) 21 | epair = (empty, empty) 22 | 23 | kopf ∷ ListView b ⇒ (b a → a, Int) 24 | kopf = (head, 32) 25 | 26 | 27 | main = println (empty :: [String]) -------------------------------------------------------------------------------- /tests/comp/Issue355.fr: -------------------------------------------------------------------------------- 1 | --- 'https://github.com/Frege/frege/issues/355 Issue #355' 2 | --- Type checking aborts with "bad types in unification" with @(extends Object)@ construct 3 | module tests.comp.Issue355 where 4 | 5 | native forN java.lang.Class.forName :: String -> IO (Class (≤Object)) throws ClassNotFoundException 6 | 7 | 8 | -- frege> forN "java.lang.Object" 9 | -- IO (Class (≤Object)) 10 | 11 | idc :: Class (≤Object) -> IO (Class Object) 12 | idc x = pure x 13 | 14 | idx x = pure x 15 | 16 | value1 :: IO (Class Object) 17 | value1 = (forN "java.lang.Object") >>= idx 18 | 19 | value2 = forN "java.lang.Object" >>= idc 20 | 21 | main :: IO Bool 22 | main = do 23 | value1 >>= println . _.getName 24 | value2 >>= println . _.getName 25 | pure true -------------------------------------------------------------------------------- /tests/comp/Issue357.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | As outlined in 'https://github.com/Frege/frege/issues/357 #357', 3 | the compiler decides that 'myFoldM' should be strict, despite the tail call 4 | 'Maybe.>>=' returns lazy. This is unfortunate, because the recursion happens 5 | on the stack, instead through a Thunk returned by >>= 6 | -} 7 | module tests.comp.Issue357 where 8 | 9 | myFoldM :: (b -> a -> Maybe b) -> b -> [a] -> Maybe b 10 | myFoldM f z (x:xs) = f z x >>= \acc -> myFoldM f acc xs 11 | myFoldM _ z [] = pure z 12 | 13 | main = println $ myFoldM (\r _ -> Just $! succ r) 0 [1..5000] 14 | -------------------------------------------------------------------------------- /tests/comp/Issue358.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | if there are ambiguities when resolving an overloaded function, choose the one 3 | with the smalles arity that still type checks. 4 | -} 5 | module tests.comp.Issue358 where 6 | 7 | main :: IO Bool 8 | main = do 9 | println ("%X".format 0xedda) 10 | println (map "%3d".format [1..10]) 11 | pure true 12 | -------------------------------------------------------------------------------- /tests/comp/Issue362.fr: -------------------------------------------------------------------------------- 1 | --- crash in typechecker 2 | --- "bad types in unification" 3 | module tests.comp.Issue362 where 4 | 5 | pure native getN getName :: Class(extends Object) -> String 6 | 7 | derive ArrayElement (Class (extends Object)) 8 | instance Show (Class (extends Object)) where 9 | show c = getN c 10 | 11 | list = [Int.javaClass :: Class(extends Object)] 12 | 13 | array = arrayFromList list 14 | 15 | c = array.[0] 16 | s = show c 17 | d = getN c 18 | 19 | main = println c >> println "Ok" -------------------------------------------------------------------------------- /tests/comp/Issue47.fr: -------------------------------------------------------------------------------- 1 | --- Example code for 'https://github.com/Frege/frege/issues/47 Issue 47' 2 | module tests.comp.Issue47 where 3 | 4 | -- import Prelude.Floating 5 | 6 | -- originally, the forall type didn't propagate to the top. 7 | -- This should be fixed by now. 8 | with (f::forall u.[u]->[u]) xs ys = (f xs, f ys) 9 | 10 | -- the following must not compile, and give message: 11 | -- type `Integer` is not as polymorphic as suggested 12 | -- in the annotation where just `u` is announced. 13 | -- wrong1 = with (map (1n+)) ['2', '3'] [true, false] 14 | 15 | -- should also work for inner functions 16 | outer xs = with reverse [false, true] 17 | where 18 | -- this is a case where we can't give a type annotation 19 | -- because the type of xs cannot be expressed. 20 | -- with :: (forall u.[u] -> [u]) -> [Bool] -> ([a], [Bool]) 21 | with (f :: forall u.[u] -> [u]) ys = (f xs, f ys) 22 | 23 | -- The following is not allowed anymore: 24 | -- worksnot f xs ys = case f of { (g::forall b.[b]->[b]) -> (g xs, g ys) } 25 | 26 | -- This used to compile and give a type error at runtime. No more! 27 | -- typefailure = worksnot (map Double.sqrt) [true, false] ['a', 'b'] 28 | 29 | main = println $ outer ["Ja", "Ok"] -------------------------------------------------------------------------------- /tests/comp/Issue55.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | Higher rank functions as record fields. 3 | 4 | Compiler aborts with 5 | 6 | > frege.runtime.Undefined: bound Meta not allowed in substTau 7 | 8 | This is due to a wrong assumption on my side, it used to work earlier. 9 | Should run once compiler is purified. 10 | -} 11 | module tests.comp.Issue55 where 12 | 13 | data Flip m a b = F (m b a) 14 | 15 | instance Functor (Flip Either a) where 16 | fmap = undefined 17 | 18 | data Rec a = R { 19 | name :: forall r. Functor r => r a -> r String, 20 | age :: a } 21 | 22 | getName R{name} x = name x 23 | 24 | --- This should be identical to Rec.{zname←} 25 | chgname :: ∀ a . Rec a 26 | → (∀p.Functor p ⇒ (p a → p String) -> (p a → p String)) 27 | → Rec a 28 | chgname r f = case r of 29 | R g a -> R (f g) a 30 | 31 | r1 = R (fmap (const "eins")) 42 32 | r2 = case r1 of 33 | R o i -> R foo i 34 | r3 = chgname r1 (const foo) 35 | 36 | 37 | updname :: Rec a -> Rec a 38 | updname r = r.{name=fmap (const "yes")} 39 | 40 | foo = fmap (const "foo") 41 | 42 | -- cfoo ∷ ∀ t x z. Functor x => z → (x t → x String) 43 | cfoo = const foo 44 | 45 | --idx :: ∀ t p.Functor p => (∀ q. Functor q => q t → q String) → p t → p String 46 | idx a = a 47 | 48 | main = do 49 | 50 | let rec = R (fmap Int.show) 42 51 | rec2 = rec.{name ← const foo} 52 | rec3 = rec.{name = fmap (const "yes")} 53 | -- the following doesn't work because the type variable also appears in the function 54 | -- rec4 = rec.{age = "acht"} 55 | println (rec.name (Just 61)) 56 | println (rec2.name (Just 62)) 57 | println (rec3.name (Just 63)) 58 | -- println rec4.age 59 | println (getName R{name = fmap show, age = 42} ([7.45])) 60 | -------------------------------------------------------------------------------- /tests/comp/Issue58.fr: -------------------------------------------------------------------------------- 1 | --- Shows that we can use exotic characters everywhere. 2 | --- हम भारतीय पर टिप्पणी कर सकते हैं. 3 | --- Але краще нехай це залишиться. 4 | module tests.comp.Issue58 where 5 | 6 | 7 | --- 𝔉𝔯𝔢𝔤𝔢 𝔰𝔢𝔩𝔟𝔰𝔱 𝔥𝔞𝔱 𝔡𝔦𝔢𝔰𝔢 𝔖𝔠𝔥𝔯𝔦𝔣𝔱 𝔟𝔢𝔫𝔲𝔱𝔷𝔱. 8 | 𝔣𝔯𝔢𝔤𝔢 = true 9 | 10 | type 𝕀 = Integer 11 | 12 | infix 6 `⩽` 13 | 14 | 𝒿𝓊𝓈𝓉 = Just 15 | 16 | --- We still can't use non spacing marks like ॖॖॖॗ 17 | बह = "ja" 18 | 19 | --- We can't do this in latin either: @ä@ is ok, but @å@ is not 20 | --- This is "a\u030a", i.e. 'a' followed by "U+030A COMBINING RING ABOVE" 21 | --- > å = 17 22 | --- We could allow non spacing marks in identifiers, though. 23 | 24 | (⩽) :: 𝕀 -> 𝕀 -> Maybe Bool 25 | 1 ⩽ 2 = 𝒿𝓊𝓈𝓉 𝔣𝔯𝔢𝔤𝔢 26 | 𝕡 ⩽ 𝕢 = 𝓷𝓸𝓽𝓱𝓲𝓷𝓰 where 𝓷𝓸𝓽𝓱𝓲𝓷𝓰 = Nothing 27 | 28 | --- Devanagari letters seem to be neither lowercase nor uppercase. 29 | main _ = do 30 | let codepoint = devanagari.charAt 0 31 | out codepoint "lowercase" Char.isLowerCase 32 | out codepoint "uppercase" Char.isUpperCase 33 | out codepoint "letter" Char.isLetter 34 | where 35 | devanagari = "ज𝔩" 36 | out :: Char -> String -> (Char -> Bool) -> IO () 37 | out cp s f = println ("The devanagari letter " ++ devanagari ++ " is " ++ s ++ ": " ++ show (f cp)) -------------------------------------------------------------------------------- /tests/comp/Issue61.fr: -------------------------------------------------------------------------------- 1 | --- 'https://github.com/Frege/frege/issues/61 Issue#61' 2 | {-- 3 | Compiler does not recognize instance methods and members 4 | that have a @$@ sign in their name. 5 | -} 6 | module tests.comp.Issue61 where 7 | 8 | 9 | data Native = pure native tests.comp.I61Java where 10 | pure native new :: Int -> Native 11 | pure native member ".mem$1" :: Native -> Int 12 | pure native method "$getMem1$" :: Native -> Int 13 | 14 | main _ = do 15 | let nat = Native.new 42 16 | print "Member mem$1 is " 17 | println nat.member 18 | print "Method $getMem1$ returns " 19 | println nat.method -------------------------------------------------------------------------------- /tests/comp/Issue65.fr: -------------------------------------------------------------------------------- 1 | --- Test for 'https://github.com/Frege/frege/issues/65 Issue65' 2 | module tests.comp.Issue65 where 3 | 4 | --- Used to go up to 2GB memory and die even when compiled with -O, which yields 5 | --- > println (take 1 (drop 30_000_000 [1..])) 6 | --- Goes up to 2GB memory and dies when not compiled with -O 7 | --- The reason being that the list is passed to a Fun2 for drop, from whence it never escapes. 8 | {-- 9 | There is a bigger problem here. 10 | Whenever we get yet-to-produce shared data via an argument and pass it on to 11 | another function (like in the the application of partially applied 'drop' 12 | through '•' below), that data stays intact until the outer function returns. 13 | 14 | Hence, to avoid memory issues, a "producer" like @[1..]@) must get passed 15 | directly to a consumer, without passing through intervening functions, no 16 | matter if those functions are proper frege functions or runtime methods 17 | that collect arguments for partial applications. 18 | 19 | Another example would be 20 | 21 | > sum [1..30_000_000] 22 | 23 | When 'sum' is not inlined, it calls 24 | 25 | > fold (+) 0 [1..30_000_000] 26 | 27 | which is in Java approximately: 28 | 29 | > return List.fold(plusfunc, 0, arg1); 30 | 31 | and sure enough, 'fold' goes through the list, discarding one front element 32 | after the other. But in 'sum', the list is still reachable through the 33 | argument, despite it is practically inaccessible, and so nothing gets garbage collected. 34 | -} 35 | main as = print "Dropping ... " >> (println . take 1 . drop 30_000_000) [1..] 36 | -------------------------------------------------------------------------------- /tests/comp/Issue66.fr: -------------------------------------------------------------------------------- 1 | --- see 'https://github.com/Frege/frege/issues/66 issue 66' 2 | --- Results in a javac error, because B.foo is lazier than A.foo 3 | module tests.comp.Issue66 where 4 | 5 | class A a where 6 | foo :: Maybe a -> Int 7 | 8 | class A b => B b where 9 | foo = maybe 0 (const 42) 10 | 11 | instance B String 12 | 13 | main = println (foo (Just "Okay")) >> println (foo (Nothing:: Maybe String)) -------------------------------------------------------------------------------- /tests/comp/Issue67.fr: -------------------------------------------------------------------------------- 1 | --- monadic list functions stack overflow early 2 | --- This program should run without @-Xss@ or @-Xmx@ settings on a 64bit JVM. 3 | module tests.comp.Issue67 where 4 | 5 | 6 | import frege.Prelude as P 7 | 8 | {- 9 | chunked !n [] = [] 10 | chunked !n xs = take n xs : chunked n (drop n xs) 11 | 12 | unsafeSequence = foldr (liftM2 (:)) (return []) 13 | 14 | sequence = fold (liftM2 (++)) (return []) . map unsafeSequence . chunked 512 15 | -- sequence' = liftM concat . map unsafeSequence . chunked 512 16 | 17 | filterM mp = fold (liftM2 (++)) (return []) . map (P.filterM mp) . chunked 512 18 | 19 | foldM p z = fold (\acc\as -> acc >>= flip (P.foldM p) as) (return z) . chunked 512 20 | 21 | sequence_ [] = return () 22 | sequence_ (x:xs) = x >> sequence_ xs 23 | 24 | -} 25 | 26 | many = [1L..100_000] 27 | manym = map Just many 28 | manyio = println "a" : replicate 19998 (print "") ++ [println "z"] 29 | 30 | main = do 31 | -- forever (println "a") 32 | sequence_ manyio 33 | println 'A' >> replicateM_ 99998 (print "") >> println 'Z' 34 | println 'A' >> replicateM 99998 (print "") >> println 'Z' 35 | println $ fmap (take 20) (sequence manym) 36 | println (fmap length . filterM (Just . even) $ many) 37 | println (foldM (\a b -> Just $! (a+b)) 0 many) 38 | -------------------------------------------------------------------------------- /tests/comp/Issue68.fr: -------------------------------------------------------------------------------- 1 | --- Test case for issue #68 2 | package tests.comp.Issue68 3 | -- inline(§, k, s, i, b) 4 | where 5 | 6 | 7 | 8 | data Y f = Y (f (Y f)) 9 | 10 | datum = Y (Left "Yes") 11 | --- This should compile without sending the code generation in an endless loop 12 | unR (Y (Left x) ) = Just x 13 | unR (Y (Right x)) = Nothing 14 | -- 15 | 16 | main = do println $ unR datum 17 | -------------------------------------------------------------------------------- /tests/comp/Issue69.fr: -------------------------------------------------------------------------------- 1 | --- Test case for Issue #69 2 | module tests.comp.Issue69 where 3 | 4 | 5 | class A a where 6 | aop :: a e -> e 7 | 8 | class B b where 9 | bop :: b e -> e 10 | 11 | class (A c, B c) => C c 12 | 13 | instance C [] where 14 | aop = head 15 | bop = head 16 | 17 | main = println (aop ["Yes"], bop ["Ok"]) -------------------------------------------------------------------------------- /tests/comp/Issue80.fr: -------------------------------------------------------------------------------- 1 | --- See 'https://github.com/Frege/frege/issues/80 the corresponding issue' 2 | module tests.comp.Issue80 where 3 | 4 | g :: ((forall b. [b] → [b]) → Int) → Int 5 | g f = undefined 6 | 7 | 8 | k1 :: (forall a. a -> a) -> Int 9 | k1 f = undefined 10 | 11 | k2 :: ([Long] -> [Long]) -> Int 12 | k2 = undefined 13 | 14 | 15 | -- dosNotWork = g k1 16 | 17 | shouldBeInt = g k2 18 | 19 | type I c = forall e. c e → c e 20 | 21 | data T (b ∷ * → *) = 22 | TA (forall 𝖆.b 𝖆 -> b 𝖆) 23 | | TB (I b) 24 | | TC { func :: forall 𝖉.Num 𝖉 => b 𝖉 -> b 𝖉 } 25 | | TD { fund :: I Maybe } where 26 | a ←→ b = a b 27 | 28 | infix 5 T.←→ 29 | 30 | 31 | y = TB reverse 32 | z = TC (fmap (1+)) 33 | 34 | -- x :: T (𝖟 :: * → *) 35 | x = TD (fmap id) 36 | 37 | main = println (z.func (Just 42)) 38 | -- z = TC Int.abs 39 | -------------------------------------------------------------------------------- /tests/comp/TDNR.fr: -------------------------------------------------------------------------------- 1 | --- interplay of type directed name resolution and overload resolution 2 | --- cover cases where TDNR on @x.m@ is only possible after overload resolution 3 | module tests.comp.TDNR where 4 | import Java.Net(URI, URL) 5 | 6 | 7 | x = _.startsWith "/" $ _.getPath $ File.new "/tmp" 8 | 9 | 10 | y = _.toURL $ _.toURI $ File.new "/tmp" 11 | -- _.toURL <$> (File.new "/tmp" >>= readonly _.toURI) -- before changing File to pure 12 | -- (File.new "/tmp" >>= readonly _.toURI >>= pure . _.toURL) -- did typecheck before 3.25.49 13 | -- clearly showing left-right bias 14 | 15 | main :: IO Bool 16 | main = do 17 | println x 18 | println . either Throwable.show _.toString $ y 19 | pure true -------------------------------------------------------------------------------- /tests/comp/Underscore.fr: -------------------------------------------------------------------------------- 1 | --- Test changed behavior of @_.foo bar@ expressions 2 | module tests.comp.Underscore where 3 | 4 | 5 | main = do 6 | println "filter (not . _.startsWith \"foobar\") [\"foo\", \"bar\", \"foobarbaz\"]" 7 | print "Used to be: " 8 | println $ filter (not . "foobar".startsWith) strings 9 | print "Should now be: " 10 | println $ filter (not . (String.`startsWith` "foobar")) strings 11 | println $ filter (not . _.startsWith "foobar") strings 12 | where 13 | strings = ["foo", "bar", "foobarbaz"] -------------------------------------------------------------------------------- /tests/hcm/Bool.fr: -------------------------------------------------------------------------------- 1 | --- This is an undocumented module 2 | module tests.hcm.Bool where 3 | 4 | --- can be used qualified or unqualified 5 | --- in patterns as well as expressions 6 | nicht True = Prelude.HaskellBool.False 7 | nicht HaskellBool.False = True 8 | 9 | alle = [False ..] 10 | 11 | {-- 12 | interestingly, we have now a function that 13 | can detect whether we run under Frege 14 | -} 15 | isThisFrege = show True == "true" 16 | 17 | import frege.prelude.PreludeBase (True Wahr, False Falsch) 18 | 19 | youCanTrickMe = Wahr == Falsch -- no, you can't -------------------------------------------------------------------------------- /tests/hcm/Identifiers.fr: -------------------------------------------------------------------------------- 1 | --- Support for identifiers starting with an underscore 2 | module tests.hcm.Identifiers where 3 | 4 | _f :: C _a => _a -> String 5 | _f _x = _g _x ++ "identifiers and type variable may start with underscores" 6 | 7 | class C _a where 8 | _g :: _a -> String 9 | 10 | instance C Bool where 11 | _g _a = show _a ++ " success" 12 | 13 | -- No conflict between mangled java keywords and corresponding 14 | -- identifiers starting with an underscore. 15 | final :: String 16 | final = "final" 17 | 18 | _final :: String 19 | _final = "_final" 20 | 21 | 22 | -- Replacement for graphic characters still works. 23 | a ® b = "®" 24 | 25 | -- Works for record field names as well. 26 | data Rec = Rec { _name :: String } 27 | 28 | _r :: Rec -> Rec 29 | _r r = r.{ _name = "newName"} 30 | 31 | -- An identifier can contain an arbitrary number apostrophes 32 | a'a' :: a' -> a' 33 | a'a' a' = a' 34 | 35 | a''a'' :: a'' -> a'' 36 | a''a'' a'' = a'' 37 | 38 | f' :: a -> a -> a 39 | f' a b = a 40 | 41 | main :: IO () 42 | main = do 43 | putStrLn $ "Hi" `f'` "ignore" 44 | 45 | -------------------------------------------------------------------------------- /tests/hcm/IdentifiersImport.fr: -------------------------------------------------------------------------------- 1 | --- Support for identifiers starting with an underscore 2 | module tests.hcm.IdentifiersImport where 3 | 4 | import tests.hcm.Identifiers (_f, final, _final, ®, a'a', a''a'') 5 | 6 | main :: IO () 7 | main = do 8 | putStrLn final 9 | putStrLn _final 10 | putStrLn $ _f True 11 | putStrLn $ 1 ® 2 12 | putStrLn $ (a'a' . a''a'') "A'p'o's't'r'o'p'h'e's" 13 | -------------------------------------------------------------------------------- /tests/hcm/Lambda.fr: -------------------------------------------------------------------------------- 1 | --- Haskell Lambda syntax 2 | 3 | module tests.hcm.Lambda where 4 | 5 | f = \a b -> (b,a) 6 | 7 | -- the following is now a syntax error 8 | -- Frege: unexpected operator : while trying to parse lambda patterns 9 | -- Haskell: parse error on input `:' 10 | -- s = \x:xs -> xs 11 | 12 | -- and this is also an error 13 | -- Frege: constructor Maybe.Just demands 1 arguments, but you gave 0 14 | -- Haskell: Constructor `Just' should have 1 argument, but has been given none 15 | -- j = \Just x -> x 16 | 17 | main = println (f true 'a') 18 | -------------------------------------------------------------------------------- /tests/hcm/Layout.fr: -------------------------------------------------------------------------------- 1 | --- Differences in layout 2 | module tests.hcm.Layout where 3 | 4 | g = 3 where 5 | 6 | neg = [ n | p ← [0..], let n = -p, n > 2 ] -- no } inserted before ] 7 | 8 | main = do 9 | print x 10 | where x = 1 11 | -------------------------------------------------------------------------------- /tests/hcm/Lexical.fr: -------------------------------------------------------------------------------- 1 | --- Show lexical incompatibilities between Frege and Haskell 2010 2 | module tests.hcm.Lexical where 3 | 4 | -- variable names 5 | 6 | æ = 4 7 | 8 | -- constructor operators 9 | 10 | data Complex = Double :+ Double 11 | 12 | 13 | -- octal integer literals 14 | 15 | twentysix = 0o32 16 | 17 | dangerous = 032 -- 32 in Haskell, 26 in Frege 18 | 19 | -- multi line strings 20 | 21 | string_with_gap = "abc/ /def" -- "abcdef" 22 | multi_line = "abc/ 23 | /def" 24 | 25 | -------------------------------------------------------------------------------- /tests/hcm/NoModuleExplicit.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | From the Haskell 2010 report: 3 | 4 | An abbreviated form of module, consisting only of the module body, is permitted. 5 | If this is used, the header is assumed to be 6 | 7 | > module Main where’ 8 | 9 | If the first lexeme in the abbreviated module is not a @{@, 10 | then the layout rule applies for the top level of the module. 11 | -} 12 | 13 | { 14 | main = println ("Explicit " ++ greetings ++ " from Main."); 15 | 16 | greetings = "greetings" } 17 | 18 | -------------------------------------------------------------------------------- /tests/hcm/NoModuleLayout.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | From the Haskell 2010 report: 3 | 4 | An abbreviated form of module, consisting only of the module body, is permitted. 5 | If this is used, the header is assumed to be 6 | 7 | > module Main where’ 8 | 9 | If the first lexeme in the abbreviated module is not a @{@, 10 | then the layout rule applies for the top level of the module. 11 | -} 12 | main = println (hello ++ " from Main") 13 | 14 | hello = "Greetings" 15 | -------------------------------------------------------------------------------- /tests/messages/Case1.fr: -------------------------------------------------------------------------------- 1 | --- Code that leads to confusing/wrong error messages 2 | module tests.messages.Case1 where 3 | 4 | {-- 5 | 6 | This gives 2 messages on line 20: 7 | 8 | > type error in expression f x type is: a expected: b 9 | 10 | This is correct, but could be more explicit by pointing out that 11 | - @f x :: a@ because @f :: b->a@ and @x :: b@ 12 | - @f x :: b@ because @f :: b->a@ and @f (f b) :: a@ 13 | 14 | > type `b` is not as polymorphic as suggested in the annotation where just `a` is announced. 15 | 16 | This is confusing and also wrong. 17 | 18 | Resolution: This message should be suppressed if there is already a type error. 19 | -} 20 | twice ∷ (a→b) → a → b 21 | twice f x = f (f x :: String) -------------------------------------------------------------------------------- /tests/nocomp/Issue102.fr: -------------------------------------------------------------------------------- 1 | --- Test for 'https://github.com/Frege/frege/issues/102 issue 102' 2 | module tests.nocomp.Issue102 where 3 | 4 | --- the following data definition is forbidden 5 | --- compiler must complain about non-introduced type variable "int" 6 | 7 | data Wrong = Falsch int 8 | 9 | --- otherwise, the following would be possible: 10 | 11 | main = println (foo (Falsch 42)) -- ClassCastException Integer -> String 12 | where 13 | foo :: Wrong -> String 14 | foo (Falsch s) = s 15 | -------------------------------------------------------------------------------- /tests/nocomp/Issue125.fr: -------------------------------------------------------------------------------- 1 | {-- 2 | Example code for 'https://github.com/Frege/frege/issues/125 issue 125' 3 | 4 | The attempt to unify mutable native types with their supertypes must fail 5 | when the supertype is not also mutable native. 6 | -} 7 | module tests.nocomp.Issue125 where 8 | 9 | 10 | pure native toString :: Object -> String 11 | 12 | wrong = toString stdin 13 | 14 | -------------------------------------------------------------------------------- /tests/nocomp/Issue286.fr: -------------------------------------------------------------------------------- 1 | --- 'https://github.com/Frege/frege/issues/286 Issue 286' 2 | --- Refuse to make native types instances of higher kinded classes 3 | module tests.nocomp.Issue286 where 4 | 5 | import frege.java.Util(List) 6 | 7 | instance Functor List where fmap = undefined 8 | 9 | newtype JList a = J (List a) 10 | 11 | instance Functor JList where fmap = undefined -------------------------------------------------------------------------------- /tests/nocomp/Issue293.fr: -------------------------------------------------------------------------------- 1 | module tests.nocomp.Issue293 where 2 | 3 | 4 | data Log t = LogA { message :: String, 5 | integer :: Maybe t } | 6 | LogB { message :: String, 7 | boolean :: Bool } 8 | newtype Logger t a = Logger { runLog :: (a, [Log t]) } 9 | instance Monad (Logger t) where 10 | pure a = Logger (a, []) 11 | (Logger (a, xs)) >>= f = Logger (a', xs ++ xs') 12 | where (a', xs') = Logger.runLog $ f a 13 | tell s = Logger ((), s) 14 | -------------------------------------------------------------------------------- /tests/nocomp/Issue348.fr: -------------------------------------------------------------------------------- 1 | module tests.nocomp.Issue348 where 2 | 3 | newtype Flip a b = Flip (b, a) 4 | 5 | instance Functor (Flip a) where 6 | fmap f (Flip (b, a)) = Flip ((f b), a) 7 | -------------------------------------------------------------------------------- /tests/nocomp/Issue47a.fr: -------------------------------------------------------------------------------- 1 | --- Example code for 'https://github.com/Frege/frege/issues/47 Issue 47' 2 | module tests.nocomp.Issue47a where 3 | 4 | -- originally, the forall type didn't propagate to the top. 5 | -- This should be fixed by now. 6 | with (f::forall 𝖚.[𝖚]->[𝖚]) xs ys = (f xs, f ys) 7 | 8 | -- the following must not compile, and give messages: 9 | -- * type error in expression map (+ 1n) type is [Integer] used as [𝖚] 10 | -- * type `Integer` is not as polymorphic as suggested 11 | -- in the annotation where just `𝖚` is announced. 12 | wrong1 = with (map (1n+)) ['2', '3'] [true, false] 13 | 14 | -------------------------------------------------------------------------------- /tests/nocomp/Issue47b.fr: -------------------------------------------------------------------------------- 1 | --- Example code for 'https://github.com/Frege/frege/issues/47 Issue 47' 2 | module tests.nocomp.Issue47b where 3 | 4 | import Prelude.Math 5 | 6 | 7 | -- The following is not allowed anymore and yields error: 8 | -- higher rank type annotations are not allowed for case patterns 9 | worksnot f xs ys = case f of { (g::forall b.[b]->[b]) -> (g xs, g ys) } 10 | 11 | -- This used to compile and give a type error at runtime. No more! 12 | typefailure = worksnot (map Double.sqrt) [true, false] ['a', 'b'] 13 | -------------------------------------------------------------------------------- /tests/nocomp/Issue53.fr: -------------------------------------------------------------------------------- 1 | module tests.nocomp.Issue53 where 2 | 3 | {-- 4 | See https://github.com/Frege/frege/issues/53 5 | 6 | Type checks without errors, but then in code generation the compiler aborts with: 7 | 8 | > F tests/nocomp/Issues53.fr:14: unknown context: Show <3251 a> 9 | 10 | Correct behaviour would be when the type checker would complain 11 | > E tests/nocomp/Issue53.fr:17: inferred type is more constrained than expected type 12 | > inferred: Show t3252 => [String] -> IO () 13 | > expected: [String] -> IO () 14 | 15 | Note that there is the implicit annotation: 16 | 17 | > main :: [String] -> IO () 18 | -} 19 | 20 | main _ = println [] 21 | -------------------------------------------------------------------------------- /tests/qc/Environment.fr: -------------------------------------------------------------------------------- 1 | --- Test properties of the 'Environment' module 2 | module tests.qc.Environment where 3 | 4 | import System.Environment as E 5 | import Test.QuickCheck 6 | 7 | -- since we don't (yet) have Test.QuickCheck.Monadic we will cheat here 8 | -- and use IO.performUnsafe since these functions doesn't actually have 9 | -- any side effects (despite their IO types) 10 | 11 | -- this may break once real main arguments are wired in, depending on 12 | -- how the tests are actually invoked: 13 | -- all we can really say is that the number of arguments is >= 0 14 | --- nowarn: unsafe 15 | o_getArgsEmpty = once ( length (IO.performUnsafe getArgs) >= 0 ) 16 | 17 | --- nowarn: unsafe 18 | o_getProgNameEmpty = once ( IO.performUnsafe (getProgName) == "" ) 19 | 20 | -- PATH should be available even on Windows so this should be a safe test: 21 | --- nowarn: unsafe 22 | o_getEnvPathOk = once ( IO.performUnsafe (getEnv "PATH") /= "" ) 23 | 24 | -- this should yield an environment variable name that we will never have: 25 | noSuchEnv = "NoSuchEnvironmentVariable" 26 | 27 | -- getEnv throws IllegalArgumentException with the name of the unknown 28 | -- environment variable as the message value: 29 | accept :: IllegalArgumentException -> IO String 30 | accept t = return ("IAE" ++ t.getMessage) 31 | 32 | --- nowarn: unsafe 33 | o_getEnvUnknownThrows = once ( IO.performUnsafe (getEnv noSuchEnv `catch` accept) == "IAE" ++ noSuchEnv ) 34 | -------------------------------------------------------------------------------- /tests/qc/Exit.fr: -------------------------------------------------------------------------------- 1 | --- Test properties of the 'Exit' module 2 | module tests.qc.Exit where 3 | 4 | import System.Exit as E 5 | import Test.QuickCheck 6 | 7 | o_ExitCodeSuccessEqOrd = once ( ExitSuccess == ExitSuccess && 8 | not ( ExitSuccess < ExitSuccess ) ) 9 | 10 | exitCodes :: Gen Int 11 | exitCodes = choose (1,99) 12 | 13 | p_ExitCodeFailureEqOrd = forAll exitCodes (\x -> 14 | ExitFailure x == ExitFailure x && 15 | ExitFailure x < ExitFailure (x + 1)) 16 | 17 | o_ExitCodeSuccessFailure = once ( ExitSuccess /= ExitFailure 1 && 18 | ExitSuccess < ExitFailure 1 ) 19 | -------------------------------------------------------------------------------- /tests/qc/JSON.fr: -------------------------------------------------------------------------------- 1 | --- Test properties of the 'Json' module 2 | module tests.qc.JSON where 3 | 4 | import frege.Prelude hiding(Object) 5 | 6 | import Data.JSON as Json(Value, runParser, parseValue, lexer, parseJSON, toJSON, fromJSON) 7 | import Test.QuickCheck as Q public 8 | 9 | instance Arbitrary Value where 10 | arbitrary = frequency [ 11 | (5, return Null), 12 | (6, Bool <$> arbitrary), 13 | (42, String <$> arbitrary), 14 | (6, Number . Double.show <$> arbitrary), 15 | (6, Number . Float.show <$> arbitrary), 16 | (6, Number . Integer.show <$> arbitrary), 17 | (6, Number . Int.show <$> arbitrary), 18 | (6, Number . Long.show <$> arbitrary), 19 | (6, Number . Short.show <$> arbitrary), 20 | -- doesn't work because @show (byte 0) == "0x00"@ 21 | -- (5, Number . Byte.show <$> arbitrary), 22 | (1, Array <$> arbitrary), 23 | (1, Struct <$> arbitrary), 24 | ] 25 | 26 | 27 | --- parsing the 'String' representation of any 'Value' yields the same 'Value' 28 | p_value = property $ \(a::Value) -> let 29 | json = show a 30 | len = length json `quot` 100 31 | coll = "json text length %d00..%d00".format len (len+1) :: String 32 | in collect coll (runParser parseValue (lexer json) == Right a) 33 | 34 | --- JSON round trip 35 | fromTo ∷ (Json.ToJSON 𝖇,Json.FromJSON 𝖇) ⇒ 𝖇 → Either String 𝖇 36 | fromTo = fromJSON . toJSON 37 | 38 | --- parsing the JSON representation of some value yields the same value 39 | checkFromTo ∷ (Json.ToJSON 𝖆,Json.FromJSON 𝖆,Eq 𝖆) ⇒ 𝖆 → Bool 40 | checkFromTo x = fromTo x == Right x 41 | 42 | p_roundUnit = once (checkFromTo ∷ () → Bool) 43 | p_roundBool = property (checkFromTo ∷ Bool → Bool) 44 | p_roundChar = property (checkFromTo ∷ Char → Bool) 45 | p_roundInt = property (checkFromTo ∷ Int → Bool) 46 | p_roundLong = property (checkFromTo ∷ Long → Bool) 47 | p_roundInteger = property (checkFromTo ∷ Integer → Bool) 48 | p_roundFloat = property (checkFromTo ∷ Float → Bool) 49 | p_roundDouble = property (checkFromTo ∷ Double → Bool) 50 | p_roundString = property (checkFromTo ∷ String → Bool) 51 | p_roundList = property (checkFromTo ∷ [String] → Bool) 52 | p_roundMaybe = property (checkFromTo ∷ Maybe [Char] → Bool) 53 | p_roundTuple = property (checkFromTo ∷ (String, Double) → Bool) 54 | 55 | 56 | main [s] = println $ do 57 | runParser parseValue (lexer s) 58 | main _ = return () -------------------------------------------------------------------------------- /tests/qc/MonoidTest.fr: -------------------------------------------------------------------------------- 1 | module tests.qc.MonoidTest where 2 | 3 | import Data.NonEmpty (nonEmpty) 4 | import Data.Monoid (Monoid, sconcat, mconcat, <>) 5 | import Test.QuickCheck 6 | 7 | checkSemigroupConcat :: (Monoid a, Eq a) => a -> [a] -> Bool 8 | checkSemigroupConcat head tail = 9 | head <> mconcat tail == sconcat (nonEmpty head tail) 10 | 11 | p_semigroupConcatStrings = 12 | property (checkSemigroupConcat :: String -> [String] -> Bool) 13 | -------------------------------------------------------------------------------- /tests/qc/PierresPrime.fr: -------------------------------------------------------------------------------- 1 | --- Issue #218 2 | module tests.qc.PierresPrime where 3 | 4 | import Test.QuickCheck 5 | 6 | prime' = f firstPrime 7 | where 8 | f n x = if (n < x) 9 | then if (mod x n == 0) 10 | then false 11 | else f (succ n) x 12 | else true 13 | firstPrime = 2 14 | 15 | prime :: (Enum a, Integral a) => a -> Bool 16 | prime = f firstPrime 17 | where 18 | f n x = if (n < x) 19 | then if (mod x n == 0) 20 | then false 21 | else f (succ n) x 22 | else true 23 | firstPrime = 2 24 | 25 | pierres_property = once (not (prime' 9) && not (prime 9)) 26 | 27 | main :: IO () 28 | main = do 29 | println $ prime' 9 30 | println $ prime 9 -------------------------------------------------------------------------------- /tests/qc/Record.fr: -------------------------------------------------------------------------------- 1 | --- Test properties of record data types 2 | module tests.qc.Record where 3 | 4 | import frege.test.QuickCheck 5 | 6 | data Int1 = Int1 { field :: Int } 7 | 8 | p_setInt1 = property $ \x -> let d = Int1 { field = x } in d.field == x 9 | 10 | 11 | --- An alias of @a -> b@ to define @instance Show@ 12 | newtype F a b = F (a -> b) 13 | instance Show (F a b) where 14 | show _ = "" 15 | instance (CoArbitrary a, Arbitrary b) => Arbitrary (F a b) where 16 | arbitrary = F <$> arbitrary 17 | 18 | 19 | --- @value'@ will be mangled to @mem$value$tick@. Will this work? 20 | data Mangled a = Mangled { value' :: a } 21 | derive Show (Mangled a) 22 | 23 | instance (Arbitrary a) => Arbitrary (Mangled a) where 24 | arbitrary = do 25 | value' <- arbitrary 26 | return Mangled { value' } 27 | 28 | -- the next two should fail unless the QC tool mangels names correctly 29 | (°°°) = once true 30 | p_accessMangled' = property $ \(x :: Mangled Int) -> let Mangled a = x in a == x.value' 31 | p_matchMangled = property $ \(x@Mangled{value'} :: Mangled Int) -> value' == x.value' 32 | p_matchMangledA = property $ \(x@Mangled{value'=a} :: Mangled Int) -> a == x.value' 33 | p_updateMangled = property $ \(b :: Bool) (x :: Mangled Int) -> let y = x.{ value' = b } in y.value' == b 34 | p_changeMangled = property $ \(F f :: F Int Bool) (x :: Mangled Int) -> let y = x.{ value' <- f } in y.value' == f (x.value') 35 | 36 | 37 | data Mangled3 a b = Mangled3 { value :: a, value' :: b, value'' :: Int } 38 | derive Show (Mangled3 a b) 39 | 40 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Mangled3 a b) where 41 | arbitrary = do 42 | value <- arbitrary 43 | value' <- arbitrary 44 | value'' <- arbitrary 45 | return Mangled3 { value, value', value'' } 46 | 47 | p_accessMangled3 = property $ \(x :: Mangled3 Int Bool) -> let Mangled3 a b c = x in 48 | a == x.value && 49 | b == x.value' && 50 | c == x.value'' 51 | p_matchMangled3 = property $ \(x@Mangled3{value, value', value''} :: Mangled3 Long Bool) -> 52 | value == x.value && 53 | value' == x.value' && 54 | value'' == x.value'' 55 | p_matchMangled3A = property $ \(x@Mangled3{value=a, value'=b, value''=c} :: Mangled3 Char ()) -> 56 | a == x.value && 57 | b == x.value' && 58 | c == x.value'' 59 | p_updateMangled3 = property $ \(a :: Int) (b :: Bool) (c :: Int) (x :: Mangled3 Char Long) -> 60 | let y = x.{ value = a, value' = b, value'' = c } in 61 | a == y.value && 62 | b == y.value' && 63 | c == y.value'' 64 | p_changeMangled3 = property $ \(F f :: F Int [Bool]) (F g :: F Char String) (F h :: F Int Int) (x :: Mangled3 Int Char) -> 65 | let y = x.{ value <- f, value' <- g, value'' <- h } in 66 | y.value == f (x.value) && 67 | y.value' == g (x.value') && 68 | y.value'' == h (x.value'') 69 | -------------------------------------------------------------------------------- /tests/qc/Regexes.fr: -------------------------------------------------------------------------------- 1 | --- This is an undocumented module 2 | module tests.qc.Regexes where 3 | 4 | import Test.QuickCheck 5 | 6 | 7 | o_replaceFst = once ("zzzdogzzzdogzzz".replaceFirst ´dog´ "cat" == "zzzcatzzzdogzzz") 8 | o_replaceAll = once ("zzzdogzzzdogzzz".replaceAll ´dog´ "cat" == "zzzcatzzzcatzzz") 9 | o_correct = once ("dogs fear cats".replaceFirst '(\w+) (\w+) (\w+)' "$3 $2 $1" == "cats fear dogs") 10 | 11 | o_match = once ("foobar" ~ '(.)\1') 12 | o_result = once expr 13 | where 14 | expr = (_.match <$> "foobar" =~ '(.)\1') == Just "oo" 15 | o_tilde2 = once ("foobar" ~~ '(.)\1' == Just "oo") 16 | o_tilde3 = once (map ("frege" ~~~ ´(..).(..)´) [0..3] 17 | == [Just "frege", Just "fr", Just "ge" , Nothing]) 18 | o_tilde2star = once $ 19 | "cats and dogs are not concatenated." ~~* ´cat|dog´ == ["cat", "dog", "cat"] 20 | 21 | o_nomatch = once ("foobar" !~ '(.)\1\1') 22 | p_not = property (\s -> !(s ~ '(.)\1') == (s !~ '(.)\1')) -------------------------------------------------------------------------------- /tests/qc/Targets.fr: -------------------------------------------------------------------------------- 1 | --- This is an undocumented module 2 | module tests.qc.Targets where 3 | 4 | import Compiler.types.Targets as T 5 | import Test.QuickCheck public 6 | 7 | {-- For a valid target string, the result of showing a decoded 8 | target should be the original string. -} 9 | p_sts ∷ Property 10 | p_sts = forAll (elements ["0.1", "x.y", "1.7", 11 | "-5.3f", "1.8.23", "9", "12345.67890" ]) 12 | stringit 13 | where 14 | stringit ∷ String → Bool 15 | stringit s = case Target.decode s of 16 | Just t → s == show t 17 | Nothing → true 18 | 19 | -------------------------------------------------------------------------------- /tests/qc/Wrappers.fr: -------------------------------------------------------------------------------- 1 | --- This is an undocumented module 2 | module tests.qc.Wrappers where 3 | 4 | import frege.test.QuickCheck public 5 | import Data.Monoid 6 | import Data.wrapper.Boolean 7 | import Data.wrapper.Dual 8 | import Data.wrapper.Num 9 | 10 | prop_any_empty_right = property (\b -> 11 | Any b <> mempty == Any b) 12 | prop_any_empty_left = property (\b -> 13 | mempty <> Any b == Any b) 14 | prop_any_disjunction = 15 | forAll arbitrary (\a -> 16 | forAll arbitrary (\b -> 17 | Any (a `oder` b) == Any a <> Any b)) 18 | 19 | prop_all_empty_right = property (\b -> 20 | All b <> mempty == All b) 21 | prop_all_empty_left = property (\b -> 22 | mempty <> All b == All b) 23 | prop_all_conjunction = 24 | forAll arbitrary (\a -> 25 | forAll arbitrary (\b -> 26 | (a `und` b) == getAll (All a <> All b))) 27 | 28 | prop_dual = property rev where 29 | rev x = (Dual x <> Dual y) == Dual (y <> x) 30 | y = "reversed" 31 | 32 | 33 | prop_prod_left = 34 | forAll arbitrary (\a -> 35 | mempty <> Product a == Product (1*a)) 36 | prop_prod_right = 37 | forAll arbitrary (\a -> 38 | Product a <> mempty == Product (a*1)) 39 | prop_prod_prod = 40 | forAll arbitrary (\(a::Float) -> 41 | forAll arbitrary (\b -> 42 | Product a <> Product b == Product (a*b))) 43 | 44 | prop_sum_left = 45 | forAll arbitrary (\a -> 46 | mempty <> Sum a == Sum (0+a)) 47 | prop_sum_right = 48 | forAll arbitrary (\a -> 49 | Sum a <> mempty == Sum (a+0)) 50 | prop_sum_sum = 51 | forAll arbitrary (\(a::Float) -> 52 | forAll arbitrary (\b -> 53 | Sum a <> Sum b == Sum (a+b))) 54 | --------------------------------------------------------------------------------