...
 
Commits (255)
Clean System Files *.abc
_Tests *.bc
_Tests.*
*.o *.o
*-sapl *.tcl
*-www
*-data
*.prj *.prj
*.prp *.prp
* Time Profile.pcl
*.exe *.exe
a.out a.out
* Time Profile.pcl
_Tests
_Tests.*
...@@ -2,20 +2,22 @@ test-nightly: ...@@ -2,20 +2,22 @@ test-nightly:
before_script: before_script:
- install_clean.sh bundle-complete - install_clean.sh bundle-complete
- apt-get update -qq - apt-get update -qq
- apt-get install -y -qq build-essential git coreutils libsnappy-dev - apt-get install -y -qq build-essential git coreutils libmariadb-dev librdkafka-dev libsnappy-dev libsqlite3-dev
- make -C src/cdeps install
image: "camilstaps/clean:nightly"
script:
- make -C tests/linux64 run
- stdbuf -o0 -e0 testproperties -IL Dynamics -d src/libraries/OS-Independent -P Quiet -r -T 'Tests 100000' -C -h -C 100m
test-stable:
before_script:
- apt-get update -qq
- apt-get install -y -qq patch build-essential coreutils libsnappy-dev
- make -C src/cdeps install - make -C src/cdeps install
- install_clean.sh "stable lib-dynamics lib-tcpip lib-graphcopy lib-graphcopy test"
- git clone https://gitlab.science.ru.nl/clean-compiler-and-rts/compiler tests/linux64/compiler
- make -C tests/linux64/compiler/main/Unix
- make -j -C tests/linux64/compiler/backendC/CleanCompilerSources -f Makefile.linux64
- mkdir -p tests/linux64/compiler/backend/Clean\ System\ Files
- ln -fs ../../backendC/CleanCompilerSources/backend.a tests/linux64/compiler/backend/Clean\ System\ Files/backend_library
image: "camilstaps/clean:nightly" image: "camilstaps/clean:nightly"
script: script:
- make -C tests/linux64 run - COCLPATH=./compiler make -C tests/linux64 run
allow_failure: true - cleantest -r testproperties --options '-IL;Dynamics;-d;src/libraries/OS-Independent;-P;OutputTestEvents;-T;Tests 100000;-T;MaxStringLength 500;-T;Bent;-C;-h;-C;100m;-r' --junit junit.xml
artifacts:
when: always
paths:
- junit.xml
reports:
junit: junit.xml
...@@ -23,8 +23,7 @@ map :: (a -> b) [a] -> [b] ...@@ -23,8 +23,7 @@ map :: (a -> b) [a] -> [b]
For short documentation items, doclines, starting with `//*` can be used. When For short documentation items, doclines, starting with `//*` can be used. When
documenting a constructor, or record field, they should be placed *after* the documenting a constructor, or record field, they should be placed *after* the
item they document. Doclines are only supported for constructors and record item they document. For example:
fields. For example:
```clean ```clean
/** /**
...@@ -37,6 +36,23 @@ fields. For example: ...@@ -37,6 +36,23 @@ fields. For example:
} }
``` ```
To add several lines of documentation to a constructor or record field, several
doclines can be used:
```clean
:: MyType
= MyConstructor args // ...
//* This constructor may require some more explanation,
//* which is added on several lines.
```
Doclines can also be added *above* a function, type, or class definition:
```clean
//* The identity function.
id :: .a -> .a
```
## Markup in documentation ## Markup in documentation
Some simple Markdown-inspired markup is allowed in documentation: Some simple Markdown-inspired markup is allowed in documentation:
...@@ -67,7 +83,7 @@ information. ...@@ -67,7 +83,7 @@ information.
| Constructor | ![][y] | | | | | | | | Constructor | ![][y] | | | | | | |
| Function | ![][y] | ![][y] | ![][y] | | | | ![][y] | ![][y] | Function | ![][y] | ![][y] | ![][y] | | | | ![][y] | ![][y]
| Generic | ![][y] | ![][y] | ![][y] | | ![][y] | | | | Generic | ![][y] | ![][y] | ![][y] | | ![][y] | | |
| Instance | | | | | | | | | Instance | ![][y] | | | | | | |
| Macro | ![][y] | ![][y] | ![][y] | ![][y]<sup>2</sup> | | | | | Macro | ![][y] | ![][y] | ![][y] | ![][y]<sup>2</sup> | | | |
| Module | ![][y] | | | | | | | | Module | ![][y] | | | | | | |
| Record field | ![][y] | | | | | | | | Record field | ![][y] | | | | | | |
...@@ -96,6 +112,18 @@ With [clean-test-properties][]' `testproperties` tool, [Gast][] test programs ...@@ -96,6 +112,18 @@ With [clean-test-properties][]' `testproperties` tool, [Gast][] test programs
can be generated with properties from docblocks. For this, several additional can be generated with properties from docblocks. For this, several additional
fields can be used, which are further documented by [clean-test-properties][]. fields can be used, which are further documented by [clean-test-properties][].
Our [standards](STANDARDS.md) require the use of tabs for indentation and spaces
for outlining. Because with properties code is included in documentation blocks,
using tabs for indentation would lead to tabs after spaces. To avoid this, we
use four spaces in this context instead. For example:
```clean
/**
* @property correctness: A.xs :: Set a:
* minList (toList xs) == findMin xs
*/
```
[clean-test-properties]: https://gitlab.science.ru.nl/clean-and-itasks/clean-test-properties [clean-test-properties]: https://gitlab.science.ru.nl/clean-and-itasks/clean-test-properties
[Gast]: https://gitlab.science.ru.nl/clean-and-itasks/gast [Gast]: https://gitlab.science.ru.nl/clean-and-itasks/gast
......
...@@ -96,7 +96,9 @@ collisions, adhere to the following conventions: ...@@ -96,7 +96,9 @@ collisions, adhere to the following conventions:
Implementation modules may import anything they like. Implementation modules may import anything they like.
## Implementing class instances and generic derives ## Implementing class instances and generic derives
Clean Platform should, where applicable, provide instances for the types it provides for classes defined in StdEnv, Gast, and Platform itself.
The applicable instances for the _general_ classes should be exported in the module of the type and not of the class. The applicable instances for the _general_ classes should be exported in the module of the type and not of the class.
This means that for example the `Functor` instance of `Maybe` should be defined in `Data.Maybe` and not in `Data.Functor`. This means that for example the `Functor` instance of `Maybe` should be defined in `Data.Maybe` and not in `Data.Functor`.
...@@ -119,6 +121,7 @@ _general_ classes are: ...@@ -119,6 +121,7 @@ _general_ classes are:
_specific_ classes are for example: _specific_ classes are for example:
- [ ] `JSONEncode, JSONDecode` from `Text.JSON` - [ ] `JSONEncode, JSONDecode` from `Text.JSON`
- [ ] `ggen, genShow` from `Gast`
- [ ] ... - [ ] ...
......
...@@ -41,3 +41,8 @@ void signal_poll(long handler, long *ok, long *state, long *handlerr) ...@@ -41,3 +41,8 @@ void signal_poll(long handler, long *ok, long *state, long *handlerr)
*ok = 0; *ok = 0;
} }
} }
int signal_ignore(long signum)
{
return signal(signum, SIG_IGN) == SIG_ERR;
}
...@@ -17,7 +17,7 @@ from Clean.Types import :: Type ...@@ -17,7 +17,7 @@ from Clean.Types import :: Type
* A wrapper around the {{`String`}} type which makes sure that multi-line * A wrapper around the {{`String`}} type which makes sure that multi-line
* documentation blocks get trimmed w.r.t. whitespace. * documentation blocks get trimmed w.r.t. whitespace.
*/ */
:: MultiLineString = MultiLine !String :: MultiLineString =: MultiLine String
class docDescription d :: !d -> Maybe Description class docDescription d :: !d -> Maybe Description
class docComplexity d :: !d -> Maybe String class docComplexity d :: !d -> Maybe String
...@@ -31,17 +31,18 @@ class docFields d :: !d -> Maybe [Maybe Description] ...@@ -31,17 +31,18 @@ class docFields d :: !d -> Maybe [Maybe Description]
class docConstructors d :: !d -> Maybe [Maybe ConstructorDoc] class docConstructors d :: !d -> Maybe [Maybe ConstructorDoc]
class docRepresentation d :: !d -> Maybe (Maybe Description) class docRepresentation d :: !d -> Maybe (Maybe Description)
class docPropertyBootstrap d :: !d -> Maybe String class docPropertyBootstrap d :: !d -> Maybe PropertyBootstrapDoc
class docPropertyTestWith d :: !d -> [PropertyVarInstantiation] class docPropertyTestWith d :: !d -> [PropertyVarInstantiation]
class docPropertyTestGenerators d :: !d -> [PropertyTestGenerator] class docPropertyTestGenerators d :: !d -> [PropertyTestGenerator]
class docProperties d :: !d -> [Property] class docProperties d :: !d -> [Property]
class docPreconditions d :: !d -> [String]
/** /**
* Documentation of a Clean module. * Documentation of a Clean module.
*/ */
:: ModuleDoc = :: ModuleDoc =
{ description :: !Maybe Description { description :: !Maybe Description
, property_bootstrap :: !Maybe MultiLineString //* For generating unit tests with clean-test , property_bootstrap :: !Maybe PropertyBootstrapDoc //* For generating unit tests with clean-test-properties
, property_test_with :: ![PropertyVarInstantiation] //* With which types to test the properties , property_test_with :: ![PropertyVarInstantiation] //* With which types to test the properties
, property_test_generators :: ![PropertyTestGenerator] , property_test_generators :: ![PropertyTestGenerator]
//* Functions to generate values of types for which Gast's {{`ggen`}} is not good enough, like {{`Map`}} //* Functions to generate values of types for which Gast's {{`ggen`}} is not good enough, like {{`Map`}}
...@@ -51,7 +52,14 @@ instance docDescription ModuleDoc ...@@ -51,7 +52,14 @@ instance docDescription ModuleDoc
instance docPropertyBootstrap ModuleDoc instance docPropertyBootstrap ModuleDoc
instance docPropertyTestWith ModuleDoc instance docPropertyTestWith ModuleDoc
instance docPropertyTestGenerators ModuleDoc instance docPropertyTestGenerators ModuleDoc
derive gDefault ModuleDoc derive gDefault ModuleDoc, PropertyBootstrapDoc
//* Belongs to `property_bootstrap` in `ModuleDoc`.
:: PropertyBootstrapDoc =
{ bootstrap_content :: !MultiLineString
, bootstrap_without_default_imports :: !Bool
//* Don't generate a default set of imports (e.g. to avoid name clashes with Gast)
}
/** /**
* Documentation of a Clean function. * Documentation of a Clean function.
...@@ -76,8 +84,26 @@ instance docVars FunctionDoc ...@@ -76,8 +84,26 @@ instance docVars FunctionDoc
instance docResults FunctionDoc instance docResults FunctionDoc
instance docType FunctionDoc instance docType FunctionDoc
instance docThrows FunctionDoc instance docThrows FunctionDoc
instance docPropertyTestWith FunctionDoc
instance docProperties FunctionDoc instance docProperties FunctionDoc
instance docPropertyTestWith FunctionDoc
instance docPreconditions FunctionDoc
/**
* Documentation of a class instance.
*/
:: InstanceDoc =
{ description :: !Maybe Description
, complexity :: !Maybe String //* E.g. "O(n log n)"
, properties :: ![Property] //* Properties of this instance
, property_test_with :: ![PropertyVarInstantiation] //* With which types to test the properties
, preconditions :: ![String] //* Preconditions for the properties
}
instance docDescription InstanceDoc
instance docComplexity InstanceDoc
instance docProperties InstanceDoc
instance docPropertyTestWith InstanceDoc
instance docPreconditions InstanceDoc
/** /**
* Documentation of a function parameter. * Documentation of a function parameter.
...@@ -98,7 +124,7 @@ instance docDescription ParamDoc ...@@ -98,7 +124,7 @@ instance docDescription ParamDoc
* the arguments (the second argument). The first argument is the name. * the arguments (the second argument). The first argument is the name.
*/ */
:: Property :: Property
= ForAll !String ![(!String,!Type)] !String = ForAll !String ![(String,Type)] !String
/** /**
* When a property type contains type variables, a `PropertyVarInstantiation` * When a property type contains type variables, a `PropertyVarInstantiation`
...@@ -123,7 +149,7 @@ instance docDescription ParamDoc ...@@ -123,7 +149,7 @@ instance docDescription ParamDoc
= PTG_Function !Type !String = PTG_Function !Type !String
| PTG_List !Type !String | PTG_List !Type !String
derive gDefault FunctionDoc, Property, PropertyVarInstantiation, PropertyTestGenerator derive gDefault FunctionDoc, InstanceDoc, Property, PropertyVarInstantiation, PropertyTestGenerator
/** /**
* Documentation of a Clean class member. * Documentation of a Clean class member.
...@@ -251,7 +277,7 @@ parseDoc :: !String -> Either ParseError (!d, ![ParseWarning]) | docBlockToDoc{| ...@@ -251,7 +277,7 @@ parseDoc :: !String -> Either ParseError (!d, ![ParseWarning]) | docBlockToDoc{|
* @representation An order list of key-value pairs. A key can occur multiple * @representation An order list of key-value pairs. A key can occur multiple
* times. The description has key `description`. * times. The description has key `description`.
*/ */
:: DocBlock :== [(!String, !String)] :: DocBlock :== [(String, String)]
/** /**
* The magic for {{`parseDoc`}}. Usually, a record type like {{`FunctionDoc`}} * The magic for {{`parseDoc`}}. Usually, a record type like {{`FunctionDoc`}}
...@@ -264,8 +290,8 @@ generic docBlockToDoc d :: !(Either [String] DocBlock) -> Either ParseError (!d, ...@@ -264,8 +290,8 @@ generic docBlockToDoc d :: !(Either [String] DocBlock) -> Either ParseError (!d,
derive docBlockToDoc UNIT, PAIR, EITHER, CONS, OBJECT, FIELD of {gfd_name}, RECORD derive docBlockToDoc UNIT, PAIR, EITHER, CONS, OBJECT, FIELD of {gfd_name}, RECORD
derive docBlockToDoc String, [], Maybe, Type derive docBlockToDoc String, [], Maybe, Type
derive docBlockToDoc ModuleDoc, FunctionDoc, ClassMemberDoc, ClassDoc, derive docBlockToDoc ModuleDoc, FunctionDoc, InstanceDoc, ClassMemberDoc,
ConstructorDoc, TypeDoc ClassDoc, ConstructorDoc, TypeDoc
/** /**
* Print a documentation block as a string. The magic happens in * Print a documentation block as a string. The magic happens in
...@@ -275,12 +301,11 @@ printDoc :: !d -> String | docToDocBlock{|*|} d ...@@ -275,12 +301,11 @@ printDoc :: !d -> String | docToDocBlock{|*|} d
/** /**
* The magic for {{`printDoc`}}. * The magic for {{`printDoc`}}.
* @param If true, return a `Left`. If false, return a `Right`.
*/ */
generic docToDocBlock d :: !Bool !d -> Either [String] DocBlock generic docToDocBlock d :: !d -> Either [String] DocBlock
derive docToDocBlock ModuleDoc, FunctionDoc, ClassMemberDoc, ClassDoc, derive docToDocBlock ModuleDoc, FunctionDoc, InstanceDoc, ClassMemberDoc,
ConstructorDoc, TypeDoc ClassDoc, ConstructorDoc, TypeDoc
/** /**
* Trace a list of ParseWarnings like StdDebug might do it * Trace a list of ParseWarnings like StdDebug might do it
......
...@@ -27,7 +27,7 @@ from Text import <+, ...@@ -27,7 +27,7 @@ from Text import <+,
import Text.Language import Text.Language
import Text.Parsers.Simple.ParserCombinators import Text.Parsers.Simple.ParserCombinators
from Clean.Types import :: Type, :: TypeRestriction from Clean.Types import :: Type, :: TypeRestriction, :: TypeContext
from Clean.Types.Parse import parseType from Clean.Types.Parse import parseType
from Clean.Types.Util import instance toString Type from Clean.Types.Util import instance toString Type
...@@ -37,7 +37,7 @@ fromMultiLine :: !MultiLineString -> String ...@@ -37,7 +37,7 @@ fromMultiLine :: !MultiLineString -> String
fromMultiLine (MultiLine s) = s fromMultiLine (MultiLine s) = s
instance docDescription ModuleDoc where docDescription d = d.ModuleDoc.description instance docDescription ModuleDoc where docDescription d = d.ModuleDoc.description
instance docPropertyBootstrap ModuleDoc where docPropertyBootstrap d = fromMultiLine <$> d.property_bootstrap instance docPropertyBootstrap ModuleDoc where docPropertyBootstrap d = d.property_bootstrap
instance docPropertyTestWith ModuleDoc where docPropertyTestWith d = d.ModuleDoc.property_test_with instance docPropertyTestWith ModuleDoc where docPropertyTestWith d = d.ModuleDoc.property_test_with
instance docPropertyTestGenerators ModuleDoc where docPropertyTestGenerators d = d.property_test_generators instance docPropertyTestGenerators ModuleDoc where docPropertyTestGenerators d = d.property_test_generators
...@@ -48,8 +48,15 @@ instance docVars FunctionDoc where docVars d = d.Functio ...@@ -48,8 +48,15 @@ instance docVars FunctionDoc where docVars d = d.Functio
instance docResults FunctionDoc where docResults d = d.FunctionDoc.results instance docResults FunctionDoc where docResults d = d.FunctionDoc.results
instance docType FunctionDoc where docType d = d.FunctionDoc.type instance docType FunctionDoc where docType d = d.FunctionDoc.type
instance docThrows FunctionDoc where docThrows d = d.FunctionDoc.throws instance docThrows FunctionDoc where docThrows d = d.FunctionDoc.throws
instance docProperties FunctionDoc where docProperties d = d.properties instance docProperties FunctionDoc where docProperties d = d.FunctionDoc.properties
instance docPropertyTestWith FunctionDoc where docPropertyTestWith d = d.FunctionDoc.property_test_with instance docPropertyTestWith FunctionDoc where docPropertyTestWith d = d.FunctionDoc.property_test_with
instance docPreconditions FunctionDoc where docPreconditions d = d.FunctionDoc.preconditions
instance docDescription InstanceDoc where docDescription d = d.InstanceDoc.description
instance docComplexity InstanceDoc where docComplexity d = d.InstanceDoc.complexity
instance docProperties InstanceDoc where docProperties d = d.InstanceDoc.properties
instance docPropertyTestWith InstanceDoc where docPropertyTestWith d = d.InstanceDoc.property_test_with
instance docPreconditions InstanceDoc where docPreconditions d = d.InstanceDoc.preconditions
instance docDescription ParamDoc where docDescription d = d.ParamDoc.description instance docDescription ParamDoc where docDescription d = d.ParamDoc.description
...@@ -79,9 +86,9 @@ where ...@@ -79,9 +86,9 @@ where
toString {ParamDoc | description=Just d} = d toString {ParamDoc | description=Just d} = d
toString _ = "" toString _ = ""
derive gDefault Type, TypeRestriction, ModuleDoc, FunctionDoc, ClassMemberDoc, derive gDefault Type, TypeRestriction, ModuleDoc, FunctionDoc, InstanceDoc, TypeContext,
ConstructorDoc, ClassDoc, TypeDoc, Property, PropertyVarInstantiation, ClassMemberDoc, ConstructorDoc, ClassDoc, TypeDoc, Property, PropertyBootstrapDoc,
MultiLineString, PropertyTestGenerator, ParamDoc PropertyVarInstantiation, MultiLineString, PropertyTestGenerator, ParamDoc
constructorToFunctionDoc :: !ConstructorDoc -> FunctionDoc constructorToFunctionDoc :: !ConstructorDoc -> FunctionDoc
constructorToFunctionDoc d = constructorToFunctionDoc d =
...@@ -151,7 +158,7 @@ docBlockToDoc{|EITHER|} fl fr doc = case fl doc of ...@@ -151,7 +158,7 @@ docBlockToDoc{|EITHER|} fl fr doc = case fl doc of
Left _ -> Left e Left _ -> Left e
docBlockToDoc{|OBJECT|} fx doc = appFst (\x -> OBJECT x) <$> fx doc docBlockToDoc{|OBJECT|} fx doc = appFst (\x -> OBJECT x) <$> fx doc
docBlockToDoc{|MultiLineString|} (Left [s]) = Right (MultiLine $ trimMultiLine $ split "\n" s, []) docBlockToDoc{|MultiLineString|} (Left [s]) = Right (MultiLine (trimMultiLine $ split "\n" s), [])
docBlockToDoc{|MultiLineString|} _ = abort "error in docBlockToDoc{|MultiLineString|}\n" docBlockToDoc{|MultiLineString|} _ = abort "error in docBlockToDoc{|MultiLineString|}\n"
docBlockToDoc{|ParamDoc|} (Left [s]) = case findName (fromString s) of docBlockToDoc{|ParamDoc|} (Left [s]) = case findName (fromString s) of
...@@ -176,6 +183,19 @@ docBlockToDoc{|Type|} (Left ss) = case [v \\ Just v <- map (parseType o fromStri ...@@ -176,6 +183,19 @@ docBlockToDoc{|Type|} (Left ss) = case [v \\ Just v <- map (parseType o fromStri
vs -> Right (last vs, []) vs -> Right (last vs, [])
docBlockToDoc{|Type|} _ = abort "error in docBlockToDoc{|Type|}\n" docBlockToDoc{|Type|} _ = abort "error in docBlockToDoc{|Type|}\n"
docBlockToDoc{|PropertyBootstrapDoc|} (Left [s]) = Right
(
{ bootstrap_content = MultiLine (trimMultiLine content)
, bootstrap_without_default_imports = without_imports
}
, []
)
where
lines = split "\n" s
without_imports = hd lines == "without default imports"
content = if without_imports (tl lines) lines
docBlockToDoc{|PropertyBootstrapDoc|} _ = abort "error in docBlockToDoc{|PropertyBootstrapDoc|}\n"
docBlockToDoc{|Property|} (Left [s]) = let [signature:property] = split "\n" s in docBlockToDoc{|Property|} (Left [s]) = let [signature:property] = split "\n" s in
parseSignature signature >>= \(sig,ws1) -> parseSignature signature >>= \(sig,ws1) ->
parseProperty property >>= \(prop,ws2) -> parseProperty property >>= \(prop,ws2) ->
...@@ -186,7 +206,7 @@ where ...@@ -186,7 +206,7 @@ where
Left es -> Left (UnknownError "failed to parse property signature") Left es -> Left (UnknownError "failed to parse property signature")
Right (name,args) -> Right (ForAll name args, []) Right (name,args) -> Right (ForAll name args, [])
where where
parser :: Parser Char (!String, ![(!String, !Type)]) parser :: Parser Char (!String, ![(String, Type)])
parser = skipSpaces *> parser = skipSpaces *>
pMany (pSatisfy ((<>) ':')) >>= \name -> pMany (pSatisfy ((<>) ':')) >>= \name ->
skipSpaces *> pToken ':' *> skipSpaces *> pToken ':' *>
...@@ -230,8 +250,8 @@ where ...@@ -230,8 +250,8 @@ where
error = Left (UnknownError "test generator could not be parsed") error = Left (UnknownError "test generator could not be parsed")
docBlockToDoc{|PropertyTestGenerator|} _ = abort "error in docBlockToDoc{|PropertyTestGenerator|}\n" docBlockToDoc{|PropertyTestGenerator|} _ = abort "error in docBlockToDoc{|PropertyTestGenerator|}\n"
derive docBlockToDoc ModuleDoc, FunctionDoc, ClassMemberDoc, ConstructorDoc, derive docBlockToDoc ModuleDoc, FunctionDoc, InstanceDoc, ClassMemberDoc,
ClassDoc, TypeDoc ConstructorDoc, ClassDoc, TypeDoc
printDoc :: !d -> String | docToDocBlock{|*|} d printDoc :: !d -> String | docToDocBlock{|*|} d
printDoc d = join "\n * " printDoc d = join "\n * "
...@@ -243,29 +263,25 @@ printDoc d = join "\n * " ...@@ -243,29 +263,25 @@ printDoc d = join "\n * "
] +++ ] +++
"\n */" "\n */"
where where
fields` = case docToDocBlock{|*|} False d of fields` = case docToDocBlock{|*|} d of
Right fs -> fs Right fs -> fs
_ -> abort "error in printDoc\n" _ -> abort "error in printDoc\n"
fields = filter ((<>) "description" o fst) fields` fields = filter ((<>) "description" o fst) fields`
desc = lookup "description" fields` desc = lookup "description" fields`
generic docToDocBlock a :: !Bool !a -> Either [String] DocBlock generic docToDocBlock a :: !a -> Either [String] DocBlock
docToDocBlock{|String|} True s = Left [s] docToDocBlock{|String|} s = Left [s]
docToDocBlock{|String|} _ _ = abort "error in docToDocBlock{|String|}\n" docToDocBlock{|[]|} fx xs = Left [x \\ Left xs` <- map fx xs, x <- xs`]
docToDocBlock{|[]|} fx True xs = Left [x \\ Left xs` <- map (fx True) xs, x <- xs`] docToDocBlock{|Maybe|} fx mb = case mb of
docToDocBlock{|[]|} _ _ _ = abort "error in docToDocBlock{|[]|}\n"
docToDocBlock{|Maybe|} fx True mb = case mb of
Nothing -> Left [] Nothing -> Left []
Just x -> fx True x Just x -> fx x
docToDocBlock{|Maybe|} _ _ _ = abort "error in docToDocBlock{|Maybe|}\n"
docToDocBlock{|PAIR|} fx fy False (PAIR x y) = case fx False x of docToDocBlock{|PAIR|} fx fy (PAIR x y) = case fx x of
Right xs -> case fy False y of Right xs -> case fy y of
Right ys -> Right (xs ++ ys) Right ys -> Right (xs ++ ys)
_ -> abort "error in docToDocBlock{|PAIR|}\n" _ -> abort "error in docToDocBlock{|PAIR|}\n"
_ -> abort "error in docToDocBlock{|PAIR|}\n" _ -> abort "error in docToDocBlock{|PAIR|}\n"
docToDocBlock{|PAIR|} _ _ _ _ = abort "error in docToDocBlock{|PAIR|}\n" docToDocBlock{|FIELD of d|} fx (FIELD x) = case fx x of
docToDocBlock{|FIELD of d|} fx False (FIELD x) = case fx True x of
Left xs -> Right [(name,x) \\ x <- xs] Left xs -> Right [(name,x) \\ x <- xs]
_ -> abort "error in docToDocBlock{|FIELD|}\n" _ -> abort "error in docToDocBlock{|FIELD|}\n"
where where
...@@ -274,36 +290,31 @@ where ...@@ -274,36 +290,31 @@ where
| endsWith "ies" d.gfd_name = d.gfd_name % (0,size d.gfd_name-4) +++ "y" | endsWith "ies" d.gfd_name = d.gfd_name % (0,size d.gfd_name-4) +++ "y"
| endsWith "s" d.gfd_name = d.gfd_name % (0,size d.gfd_name-2) | endsWith "s" d.gfd_name = d.gfd_name % (0,size d.gfd_name-2)
| otherwise = d.gfd_name | otherwise = d.gfd_name
docToDocBlock{|FIELD|} _ _ _ = abort "error in docToDocBlock{|FIELD|}\n" docToDocBlock{|RECORD|} fx (RECORD x) = fx x
docToDocBlock{|RECORD|} fx False (RECORD x) = fx False x
docToDocBlock{|RECORD|} _ _ _ = abort "error in docToDocBlock{|RECORD|}\n"
docToDocBlock{|ParamDoc|} True pd = case pd.ParamDoc.name of docToDocBlock{|ParamDoc|} pd = case pd.ParamDoc.name of
Nothing -> case pd.ParamDoc.description of Nothing -> case pd.ParamDoc.description of
Nothing -> Left [] Nothing -> Left []
Just d -> Left [d] Just d -> Left [d]
Just n -> case pd.ParamDoc.description of Just n -> case pd.ParamDoc.description of
Nothing -> Left [n] Nothing -> Left [n]
Just d -> Left [n +++ ": " +++ d] Just d -> Left [n +++ ": " +++ d]
docToDocBlock{|ParamDoc|} _ _ = abort "error in docToDocBlock{|ParamDoc|}\n" docToDocBlock{|MultiLineString|} (MultiLine s) = Left [s]
docToDocBlock{|MultiLineString|} True (MultiLine s) = Left [s] docToDocBlock{|Type|} t = Left [toString t]
docToDocBlock{|MultiLineString|} _ _ = abort "error in docToDocBlock{|MultiLineString|}\n" docToDocBlock{|PropertyBootstrapDoc|} bs_doc = Left $ [ if bs_doc.bootstrap_without_default_imports " without default imports" ""
docToDocBlock{|Type|} True t = Left [toString t] : map ((+++) " ") $ split "\n" $ fromMultiLine bs_doc.bootstrap_content
docToDocBlock{|Type|} _ _ = abort "error in docToDocBlock{|Type|}\n" ]
docToDocBlock{|Property|} True (ForAll name args impl) = Left docToDocBlock{|Property|} (ForAll name args impl) = Left
[name +++ ": A." +++ join "; " [a +++ " :: " <+ t \\ (a,t) <- args] +++ ":\n" +++ impl] [name +++ ": A." +++ join "; " [a +++ " :: " <+ t \\ (a,t) <- args] +++ ":\n" +++ impl]
docToDocBlock{|Property|} _ _ = abort "error in docToDocBlock{|Property|}\n" docToDocBlock{|PropertyVarInstantiation|} (PropertyVarInstantiation (a,t)) = Left [a +++ " = " <+ t]
docToDocBlock{|PropertyVarInstantiation|} True (PropertyVarInstantiation (a,t)) = Left [a +++ " = " <+ t] docToDocBlock{|PropertyTestGenerator|} ptg = Left [t <+ "\n" +++ imp]
docToDocBlock{|PropertyVarInstantiation|} _ _ = abort "error in docToDocBlock{|PropertyVarInstantiation|}\n"
docToDocBlock{|PropertyTestGenerator|} True ptg = Left [t <+ "\n" +++ imp]
where where
(t,imp) = case ptg of (t,imp) = case ptg of
PTG_Function t imp -> (t,imp) PTG_Function t imp -> (t,imp)
PTG_List t imp -> (t,imp) PTG_List t imp -> (t,imp)
docToDocBlock{|PropertyTestGenerator|} _ _ = abort "error in docToDocBlock{|PropertyTestGenerator|}\n"
derive docToDocBlock ModuleDoc, FunctionDoc, ClassMemberDoc, ClassDoc, derive docToDocBlock ModuleDoc, FunctionDoc, InstanceDoc, ClassMemberDoc,
ConstructorDoc, TypeDoc ClassDoc, ConstructorDoc, TypeDoc
trimMultiLine :: ![String] -> String trimMultiLine :: ![String] -> String
trimMultiLine ss = join "\n" [s % (trimn, size s - 1) \\ s <- ss] trimMultiLine ss = join "\n" [s % (trimn, size s - 1) \\ s <- ss]
......
...@@ -26,15 +26,15 @@ readModule filename w ...@@ -26,15 +26,15 @@ readModule filename w
# (ok,f,w) = fopen filename FReadText w # (ok,f,w) = fopen filename FReadText w
| not ok = (Error ("Couldn't open " +++ filename), w) | not ok = (Error ("Couldn't open " +++ filename), w)
# (mod_id, ht) = putIdentInHashTable modname (IC_Module NoQualifiedIdents) ht # (mod_id, ht) = putIdentInHashTable modname (IC_Module NoQualifiedIdents) ht
# ((b1,b2,pm,ht,f),w) = accFiles (wantModule` f "" icl mod_id.boxed_ident NoPos True ht stderr) w # ((b1,b2,pm,ht,f),w) = accFiles (wantModule` f "" icl mod_id.boxed_ident NoPos ht stderr) w
# (ok,w) = fclose f w # (ok,w) = fclose f w
| not ok = (Error ("Couldn't close " +++ filename), w) | not ok = (Error ("Couldn't close " +++ filename), w)
= (Ok (pm, ht), w) = (Ok (pm, ht), w)
where where
icl = endsWith "icl" filename icl = endsWith "icl" filename
wantModule` :: !*File !{#Char} !Bool !Ident !Position !Bool !*HashTable !*File !*Files wantModule` :: !*File !{#Char} !Bool !Ident !Position !*HashTable !*File !*Files
-> ((!Bool,!Bool,!ParsedModule, !*HashTable, !*File), !*Files) -> ((!Bool,!Bool,!ParsedModule, !*HashTable, !*File), !*Files)
wantModule` f s b1 i p b2 ht io fs wantModule` f s b1 i p ht io fs
# (b1,b2,pm,ht,f,fs) = wantModule f s b1 i p b2 ht io fs # (b1,b2,pm,ht,f,fs) = wantModule f s b1 i p ht io fs
= ((b1,b2,pm,ht,f),fs) = ((b1,b2,pm,ht,f),fs)
...@@ -12,13 +12,16 @@ import StdString ...@@ -12,13 +12,16 @@ import StdString
import StdTuple import StdTuple
import Control.Monad import Control.Monad
import Data.Bifunctor
import Data.Error import Data.Error
from Data.Func import $
import Data.Functor import Data.Functor
from Data.Map import :: Map(..), newMap, put, get from Data.Map import :: Map(..), newMap, put, get, alter
import Data.Maybe import Data.Maybe
import Data.Tuple
import System.File import System.File
import System.FilePath import System.FilePath
from Text import class Text(startsWith), instance Text String from Text import class Text(concat,startsWith), instance Text String
from Heap import :: Heap, :: HeapN, :: Ptr{pointer}, :: PtrN(Ptr), readPtr from Heap import :: Heap, :: HeapN, :: Ptr{pointer}, :: PtrN(Ptr), readPtr
from syntax import from syntax import
...@@ -34,7 +37,7 @@ from syntax import ...@@ -34,7 +37,7 @@ from syntax import
:: CollectedDefinitions, :: CollectedDefinitions,
:: ComponentNrAndIndex, :: ComponentNrAndIndex,
:: ConsDef, :: ConsDef,
:: DclInstanceMemberTypeAndFunction, :: DclInstanceMemberTypeAndFunctions,
:: Declaration, :: Declaration,
:: FileName, :: FileName,
:: FunctionOrMacroIndex, :: FunctionOrMacroIndex,
...@@ -55,7 +58,7 @@ from syntax import ...@@ -55,7 +58,7 @@ from syntax import
:: ParsedDefinition(..), :: ParsedDefinition(..),
:: ParsedExpr, :: ParsedExpr,
:: ParsedImport, :: ParsedImport,
:: ParsedInstance{pi_pos}, :: ParsedInstance{pi_ident,pi_pos},
:: ParsedInstanceAndMembers{pim_pi}, :: ParsedInstanceAndMembers{pim_pi},
:: ParsedModule, :: ParsedModule,
:: ParsedSelector{ps_field_pos,ps_field_ident}, :: ParsedSelector{ps_field_pos,ps_field_ident},
...@@ -97,7 +100,7 @@ scanCommentsFile f ...@@ -97,7 +100,7 @@ scanCommentsFile f
:: ScanState = :: ScanState =
{ comment_level :: !Int { comment_level :: !Int
, comment_idxs :: ![(!Int,!Int,!Int)] // line, col, idx , comment_idxs :: ![(Int,Int,Int)] // line, col, idx
, ln :: !Int , ln :: !Int
, col :: !Int , col :: !Int
, input :: !String , input :: !String
...@@ -115,17 +118,20 @@ defaultScanState = ...@@ -115,17 +118,20 @@ defaultScanState =
} }
advance :: !ScanState -> ScanState advance :: !ScanState -> ScanState
advance ss = {ss & col=ss.col+1, idx=ss.idx+1} advance ss = case ss.input.[ss.idx] of
'\t' -> {ss & col=ss.col+4, idx=ss.idx+1} // We assume that there are no tabs in a line
'\n' -> {ss & ln=ss.ln+1, col=0, idx=ss.idx+1}
_ -> {ss & col=ss.col+1, idx=ss.idx+1}
scan :: !ScanState -> (![CleanComment], !ScanState) scan :: !ScanState -> (![CleanComment], !ScanState)
scan ss=:{idx} scan ss=:{idx}
| idx >= size ss.input = ([], ss) | idx >= size ss.input = ([], ss)
| otherwise = case [ss.input.[i] \\ i <- [idx..]] of | otherwise = case [ss.input.[i] \\ i <- [idx..]] of
['\r':_] [s:_] | s=='\r' || s=='\n' || s=='\t'
-> scan (advance ss) -> scan (advance ss)
['\n':_] ['//':_]
-> scan {ss & idx=idx+1, ln=ss.ln+1, col=0} | ss.comment_level <> 0
['//':_] | ss.comment_level == 0 -> scan (scan_to_newline ss)
# cmnt = # cmnt =
{ line = ss.ln { line = ss.ln
, column = ss.col , column = ss.col
...@@ -134,7 +140,9 @@ scan ss=:{idx} ...@@ -134,7 +140,9 @@ scan ss=:{idx}
, multiline = False , multiline = False
} }
# ss = scan_to_newline ss # ss = scan_to_newline ss
# cmnt & content = ss.input % (idx+2,ss.idx-1) # content = ss.input % (idx+2,ss.idx-1)
# (extra_content,ss) = collect_single_line_comments cmnt.line cmnt.column ss
# cmnt & content = concat [content:extra_content]
# (cmnts,ss) = scan ss # (cmnts,ss) = scan ss
-> ([cmnt:cmnts],ss) -> ([cmnt:cmnts],ss)
['/*':_] ['/*':_]
...@@ -166,13 +174,32 @@ scan ss=:{idx} ...@@ -166,13 +174,32 @@ scan ss=:{idx}
-> scan (skip_string_literal '"' (advance ss)) -> scan (skip_string_literal '"' (advance ss))
_ _
-> scan (advance ss) -> scan (advance ss)
where
collect_single_line_comments :: !Int !Int !ScanState -> (![String], !ScanState)
collect_single_line_comments ln col ss
# ss=:{idx} = skip_whitespace ss
| ss.ln==ln+1 && ss.col==col
&& ss.idx<size ss.input-2
&& ss.input.[idx]=='/' && ss.input.[idx+1]=='/'
# ss = scan_to_newline ss
# content = ss.input % (idx+2,ss.idx-1)
# (cmnts,ss) = collect_single_line_comments (ln+1) col ss
= ([content:cmnts],ss)
= ([],ss)
scan_to_newline :: !ScanState -> ScanState scan_to_newline :: !ScanState -> ScanState
scan_to_newline ss scan_to_newline ss
| ss.idx >= size ss.input = ss | ss.idx >= size ss.input = ss
# c = ss.input.[ss.idx] # c = ss.input.[ss.idx]
| c == '\n' = {ss & ln=ss.ln+1, col=0, idx=ss.idx+1} # ss = advance ss
| otherwise = scan_to_newline (advance ss) = if (c=='\n') ss (scan_to_newline ss)
skip_whitespace :: !ScanState -> ScanState
skip_whitespace ss
| ss.idx >= size ss.input = ss
# c = ss.input.[ss.idx]
| isSpace c = skip_whitespace (advance ss)
| otherwise = ss
skip_list_literal :: !ScanState -> ScanState skip_list_literal :: !ScanState -> ScanState
skip_list_literal ss skip_list_literal ss
...@@ -215,14 +242,14 @@ where ...@@ -215,14 +242,14 @@ where
instance < Position instance < Position
where where
< a b = index a < index b (<) a b = index a < index b
where where
index (FunPos f l n) = (f, l, n) index (FunPos f l n) = (f, l, n)
index (LinePos f l) = (f, l, "") index (LinePos f l) = (f, l, "")
index (PreDefPos id) = ("", -1, id.id_name) index (PreDefPos id) = ("", -1, id.id_name)
index NoPos = ("", -2, "") index NoPos = ("", -2, "")
instance < CommentIndex where < (CI a b c) (CI d e f) = (a,b,c) < (d,e,f) instance < CommentIndex where (<) (CI a b c) (CI d e f) = (a,b,c) < (d,e,f)
putCC k v coll :== case commentIndex k of putCC k v coll :== case commentIndex k of
Nothing -> coll Nothing -> coll
...@@ -245,7 +272,7 @@ collectComments comments pm ...@@ -245,7 +272,7 @@ collectComments comments pm
# (_,_,coll) = collect comments Nothing pm.mod_defs coll # (_,_,coll) = collect comments Nothing pm.mod_defs coll
= coll = coll
collect :: ![CleanComment] !(Maybe CleanComment) ![a] !CollectedComments -> (![CleanComment], !Maybe CleanComment, !CollectedComments) | pos, commentIndex, children a collect :: ![CleanComment] !(Maybe CleanComment) ![a] !CollectedComments -> (![CleanComment], !Maybe CleanComment, !CollectedComments) | pos, singleLineAbove, commentIndex, children a
collect cc prev [] coll = (cc, prev, coll) collect cc prev [] coll = (cc, prev, coll)
collect [] (Just prev) [pd:pds] coll = ([], Nothing, putCC pd prev coll) collect [] (Just prev) [pd:pds] coll = ([], Nothing, putCC pd prev coll)
collect [] Nothing _ coll = ([], Nothing, coll) collect [] Nothing _ coll = ([], Nothing, coll)
...@@ -253,9 +280,9 @@ collect [{content}:cs] prev pds coll | not (startsWith "*" content) = collect cs ...@@ -253,9 +280,9 @@ collect [{content}:cs] prev pds coll | not (startsWith "*" content) = collect cs
collect allcmnts=:[c:cs] prev allpds=:[pd:pds] coll = case c canBelongTo pd of collect allcmnts=:[c:cs] prev allpds=:[pd:pds] coll = case c canBelongTo pd of
Nothing -> collect allcmnts prev pds coll Nothing -> collect allcmnts prev pds coll
Just True -> case prev of Just True -> case prev of
Just prev | prev.multiline && not c.multiline Just prev | not (singleLineAbove pd) && not c.multiline
# coll = putCC pd prev coll # coll = putCC pd prev coll
# (allcmnts,prev,coll) = recurse allcmnts (Just c) (children pd) coll # (allcmnts,prev,coll) = recurse allcmnts Nothing (children pd) coll
-> collect allcmnts prev pds coll -> collect allcmnts prev pds coll
_ _
-> collect cs (Just c) allpds coll -> collect cs (Just c) allpds coll
...@@ -271,7 +298,7 @@ where ...@@ -271,7 +298,7 @@ where
recurse cs prev (Children xs) coll = collect cs prev xs coll recurse cs prev (Children xs) coll = collect cs prev xs coll
collect _ _ _ _ = abort "internal error in Clean.Parse.Comments.collect\n" collect _ _ _ _ = abort "internal error in Clean.Parse.Comments.collect\n"
:: Children = E.t: Children ![t] & pos, commentIndex, children t :: Children = E.t: Children ![t] & pos, singleLineAbove, commentIndex, children t
class children a :: !a -> Children class children a :: !a -> Children
...@@ -290,11 +317,27 @@ where ...@@ -290,11 +317,27 @@ where
instance children ParsedSelector where children ps = Children (tl [ps]) instance children ParsedSelector where children ps = Children (tl [ps])
instance children ParsedConstructor where children pc = Children (tl [pc]) instance children ParsedConstructor where children pc = Children (tl [pc])
(canBelongTo) infix :: !CleanComment !a -> Maybe Bool | pos a (canBelongTo) infix :: !CleanComment !a -> Maybe Bool | pos, singleLineAbove a
(canBelongTo) {line,multiline} p = pos p >>= \p -> case p of (canBelongTo) {line,column,multiline} elem
FunPos _ ln _ -> Just (if multiline (>) (>=) ln line) | singleLineAbove elem && column > 4
LinePos _ ln -> Just (if multiline (>) (>=) ln line) = Just False
_ -> Nothing | not (singleLineAbove elem) && column < 4
= Just False
= pos elem >>= \p -> case p of
FunPos _ ln _ -> Just (if multiline (>) (if (singleLineAbove elem) (>=) eq_or_one_less) ln line)
LinePos _ ln -> Just (if multiline (>) (if (singleLineAbove elem) (>=) eq_or_one_less) ln line)
_ -> Nothing
where
eq_or_one_less a b
| column <= 8 // probably meant for the thing a line above
= a==b || a+1==b
= a==b
// If true, single-line documentation should be given above the element.
class singleLineAbove a :: !a -> Bool
instance singleLineAbove ParsedDefinition where singleLineAbove _ = True
instance singleLineAbove ParsedSelector where singleLineAbove _ = False
instance singleLineAbove ParsedConstructor where singleLineAbove _ = False
class pos a :: !a -> Maybe Position class pos a :: !a -> Maybe Position
...@@ -333,6 +376,8 @@ where ...@@ -333,6 +376,8 @@ where
commentIndex pd = case pd of commentIndex pd = case pd of
PD_Function pos id is_infix args rhs kind -> Just (CI "PD_Function" pos id.id_name) PD_Function pos id is_infix args rhs kind -> Just (CI "PD_Function" pos id.id_name)
PD_TypeSpec pos id prio type specials -> Just (CI "PD_TypeSpec" pos id.id_name) PD_TypeSpec pos id prio type specials -> Just (CI "PD_TypeSpec" pos id.id_name)
PD_Instance {pim_pi=pi} -> Just (CI "PD_Instance" pi.pi_pos pi.pi_ident.id_name)
PD_Instances [{pim_pi=pi}:_] -> Just (CI "PD_Instances" pi.pi_pos pi.pi_ident.id_name)
PD_Class cd pds -> Just (CI "PD_Class" cd.class_pos cd.class_ident.id_name) PD_Class cd pds -> Just (CI "PD_Class" cd.class_pos cd.class_ident.id_name)
PD_Type ptd -> Just (CI "PD_Type" ptd.td_pos ptd.td_ident.id_name) PD_Type ptd -> Just (CI "PD_Type" ptd.td_pos ptd.td_ident.id_name)
PD_Generic gd -> Just (CI "PD_Generic" gd.gen_pos gd.gen_ident.id_name) PD_Generic gd -> Just (CI "PD_Generic" gd.gen_pos gd.gen_ident.id_name)
......
...@@ -14,13 +14,21 @@ where ...@@ -14,13 +14,21 @@ where
lookup k [] = k lookup k [] = k
lookup k [(k`,v):m] = if (k == k`) v (lookup k m) lookup k [(k`,v):m] = if (k == k`) v (lookup k m)
namemap = namemap =:
[ ("_Nil", "[]") [ ("_Nil", "[]")
, ("_nil", "[|]") , ("_nil", "[|]")
, ("_|Nil", "[|]") , ("_|Nil", "[|]")
, ("_#Nil", "[#]") , ("_#Nil", "[#]")
, ("_Unit", "()") , ("_Nothing", "?^None")
] , ("_#Nothing", "?#None")
, ("_!Nothing", "?None")
, ("_|Nothing", "?|None")
, ("_Just", "?^Just")
, ("_#Just", "?#Just")
, ("_!Just", "?Just")
, ("_|Just", "?|Just")
, ("_Unit", "()")
]
instance print Import instance print Import
where where
...@@ -50,8 +58,8 @@ where ...@@ -50,8 +58,8 @@ where
= print st (":: " :+: t :+: ('(',conses,')')) = print st (":: " :+: t :+: ('(',conses,')'))
print st (ID_Record t fields) print st (ID_Record t fields)
= print st (":: " :+: t :+: ('{',fields,'}')) = print st (":: " :+: t :+: ('{',fields,'}'))
print st (ID_Instance cls _ (ts, tcs)) print st (ID_Instance cls _ ts)
= print st (cls :+: join_start st " " ts :+: if (isEmpty tcs) "" (" | " +++ join st " & " tcs)) = print st (cls :+: join_start st " " ts)
print st (ID_Generic id _) print st (ID_Generic id _)
= print st ("generic " :+: id) = print st ("generic " :+: id)
......
...@@ -47,11 +47,11 @@ where ...@@ -47,11 +47,11 @@ where
print st (PD_Function _ id isinfix args rhs fk) print st (PD_Function _ id isinfix args rhs fk)
= print stnp (id` :+: join_start stp " " args :+: if show_eq eq "" :+: rhs) = print stnp (id` :+: join_start stp " " args :+: if show_eq eq "" :+: rhs)
where where
stnp = {st & cpp_parens=False} stnp = {st & cpp_funkind=fk, cpp_parens=False}
stp = {st & cpp_parens=True} stp = {st & cpp_funkind=fk, cpp_parens=True}
id` = if isinfix ("(" :+: id :+: ")") (id :+: PrintNil) id` = if isinfix ("(" :+: id :+: ")") (id :+: PrintNil)
show_eq = not (compound_rhs rhs.rhs_alts) show_eq = not (compound_rhs rhs.rhs_alts)
eq = case fk of FK_Macro = " :== "; _ = " = " eq = print st (" " :+: fk :+: " ")
print st (PD_Type {td_ident,td_args,td_attribute,td_rhs}) print st (PD_Type {td_ident,td_args,td_attribute,td_rhs})
= print st (":: " :+: td_attribute :+: td_ident :+: join_start st " " td_args :+: equals :+: td_rhs) = print st (":: " :+: td_attribute :+: td_ident :+: join_start st " " td_args :+: equals :+: td_rhs)
where where
...@@ -147,14 +147,14 @@ where ...@@ -147,14 +147,14 @@ where
= printp st (cv :+: " " :+: join {st & cpp_parens=True} " " ats) = printp st (cv :+: " " :+: join {st & cpp_parens=True} " " ats)
print st (TB bt) print st (TB bt)
= print st bt = print st bt
//print st (TFA atvs type)
// = "TFA"
print st (GTV tv) print st (GTV tv)
= print st (tv :+: "^") = print st (tv :+: "^")
print st (TV tv) print st (TV tv)
= print st tv = print st tv
print st (TFA atvs type)
= print {st & cpp_parens=False} ("(A." :+: join st " " atvs :+: ": " :+: type :+: ")")
print st (TFAC atvs t tc) print st (TFAC atvs t tc)
= print st ("(A." :+: join st " " atvs :+: ": " :+: t :+: " | " :+: join st " & " tc :+: ")") = print {st & cpp_parens=False} ("(A." :+: join st " " atvs :+: ": " :+: t :+: " | " :+: join st " & " tc :+: ")")
print st (TQualifiedIdent id s []) print st (TQualifiedIdent id s [])
= print st ("'" :+: id :+: "'." :+: s) = print st ("'" :+: id :+: "'." :+: s)
print st (TQualifiedIdent id s ats) print st (TQualifiedIdent id s ats)
...@@ -205,14 +205,18 @@ where ...@@ -205,14 +205,18 @@ where
lookup "_!List" = Yes ("[!" :+: join stnp " " ats :+: "]") lookup "_!List" = Yes ("[!" :+: join stnp " " ats :+: "]")
lookup "_List!" lookup "_List!"
| isEmpty ats = Yes ("[ !]" :+: PrintNil) | isEmpty ats = Yes ("[ !]" :+: PrintNil)
| otherwise = Yes ("[" :+: join stnp " " ats :+: "!]") | otherwise = Yes ("[" :+: join stnp " " ats :+: "!]")
lookup "_!List!" = Yes ("[!" :+: join stnp " " ats :+: "!]") lookup "_!List!" = Yes ("[!" :+: join stnp " " ats :+: "!]")
lookup "_|List" = Yes ("[|" :+: join stnp " " ats :+: "]") lookup "_|List" = Yes ("[|" :+: join stnp " " ats :+: "]")
lookup "_#List" = Yes ("[#" :+: join stnp " " ats :+: "]") lookup "_#List" = Yes ("[#" :+: join stnp " " ats :+: "]")
lookup "_#List!" = Yes ("[#" :+: join stnp " " ats :+: "!]") lookup "_#List!" = Yes ("[#" :+: join stnp " " ats :+: "!]")
lookup "_Array" = Yes ("{" :+: join stnp " " ats :+: "}") lookup "_Array" = Yes ("{" :+: join stnp " " ats :+: "}")
lookup "_#Array" = Yes ("{#" :+: join stnp " " ats :+: "}") lookup "_#Array" = Yes ("{#" :+: join stnp " " ats :+: "}")
lookup "_!Array" = Yes ("{!" :+: join stnp " " ats :+: "}") lookup "_32#Array" = Yes ("{32#" :+: join stnp " " ats :+: "}")
lookup "_!Array" = Yes ("{!" :+: join stnp " " ats :+: "}")
lookup "_Maybe" = Yes (if (isEmpty ats) ("(?^)" :+: PrintNil) ("(?^ " :+: join stnp " " ats :+: ")"))
lookup "_!Maybe" = Yes (if (isEmpty ats) ("(?)" :+: PrintNil) ("(? " :+: join stnp " " ats :+: ")"))
lookup "_#Maybe" = Yes (if (isEmpty ats) ("(?#)" :+: PrintNil) ("(?# " :+: join stnp " " ats :+: ")"))
lookup name lookup name
| name % (0,5) == "_Tuple" | name % (0,5) == "_Tuple"
| length ats == arity = Yes ("(" :+: join stnp "," types :+: ")") | length ats == arity = Yes ("(" :+: join stnp "," types :+: ")")
......
definition module Clean.PrettyPrint.Expression definition module Clean.PrettyPrint.Expression
from syntax import :: ParsedExpr, :: Rhs, :: OptGuardedAlts from syntax import :: ParsedExpr, :: Rhs, :: OptGuardedAlts, :: FunKind
from Clean.PrettyPrint.Util import class print from Clean.PrettyPrint.Util import class print
instance print ParsedExpr, Rhs instance print ParsedExpr, Rhs, FunKind
/** /**
* `True` iff the right-hand side is a {{`GuardedAlts`}} or {{`UnguardedExpr`}} * `True` iff the right-hand side is a {{`GuardedAlts`}} or {{`UnguardedExpr`}}
......
...@@ -11,6 +11,14 @@ import Clean.PrettyPrint.Util ...@@ -11,6 +11,14 @@ import Clean.PrettyPrint.Util
import Clean.PrettyPrint.Common import Clean.PrettyPrint.Common
import Clean.PrettyPrint.Definition import Clean.